こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

VBA 特定もセルに入力で実行

下記のコードを実行した際は問題なく実行されるのですが
これを特定のセルに値が入力された際に動かそうとするとエラーになってしまいます。
Sub PaintTargetCharacter()
Dim FoundCell As Range, FoundCell2 As Range
Dim Addr As String
Dim Addr2 As String
Dim SearchArea As Range
Dim SearchArea2 As Range

Application.ScreenUpdating = False
ActiveCell.Interior.ColorIndex = 0

'検索対象範囲
Set SearchArea = Worksheets("G番情報").Range("AE6:BG6")

'検索実行
Set FoundCell = SearchArea.Find(What:=ActiveCell.Offset(0, -1), LookIn:=xlValues, _
LookAt:=xlPart, MatchCase:=False, MatchByte:=False)

'検索文字列を含むセルがない場合は終了
If FoundCell Is Nothing Then Exit Sub

Set SearchArea2 = Range(FoundCell.Offset(1, 0), FoundCell.Offset(33, 0))
Set FoundCell2 = SearchArea2.Find(What:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, MatchCase:=False, MatchByte:=False)

If FoundCell2 Is Nothing Then Exit Sub

FoundCell2.Copy Destination:=ActiveCell
Application.ScreenUpdating = True

End Sub



当然、特定のセルで値を入力後エンターキーを押すとアクティブセルは下に下がってしまうので
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Target.select

Call PaintTargetCharacter

End Sub

としているのですが
Set FoundCell = SearchArea.Find(What:=ActiveCell.Offset(0, -1), LookIn:=xlValues, _
LookAt:=xlPart, MatchCase:=False, MatchByte:=False)
の部分でエラーが起きてしまいます。
また停止してシートに戻るとセルのカーソル表示が消えてしまいます。
この現象はシートを閉じて再度開くと直りますが
なにかエラーと関係しているのでしょうか?

初心者なのでおかしな部分が多々あると思います。
ご指摘などあれば宜しくお願いします。

投稿日時 - 2018-03-08 09:14:27

QNo.9449863

すぐに回答ほしいです

質問者が選んだベストアンサー

なんとなく、よくわからないのでヒントだけでも。

> 入力後エンターキーを押すとアクティブセルは下に下がってしまう
> Set FoundCell = SearchArea.Find(What:=ActiveCell.Offset(0, -1),
Offsetは、
  レンジ.Offset(行方向, 列方向)
ですよ。

特定のセル(範囲)が変更された時だけ動かしたいなら
Private Sub Worksheet_Change(ByVal Target As Range)
  If Intersect(Target, Range("A1:B1")) Is Nothing Then
    ’ 範囲外の時
    Exit Sub
  Else
    ' 範囲内の時
    Target.Select
  End If
End Sub
としてやればできそうな気がします。

別のモジュールを呼び出したいときは、
Target を Public変数に入れておくのも手段の一つです。
Public myRange As Range
Private Sub Worksheet_Change(ByVal Target As Range)
  Set myRange = Target
  Call PaintTargetCharacter
End Sub
こんな感じで。
コレでOffsetを使わずに処理を進められます。

当然、組み合わせてもOK。
ということで、まずはヒントだけどうぞ。

投稿日時 - 2018-03-08 11:34:32

補足

ありがとうございます。頂いたコードをもとに下記のようにやってみましたが、機能しませんでした。
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Intersect(Target, Range("B9")) Is Nothing Then
' 範囲外の時
Exit Sub
Else
Set myRange = Target.Offset(0, -1)
' 範囲内の時
Target.Select
Call PaintTargetCharacter
End If


End Sub


Sub PaintTargetCharacter()
Dim FoundCell As Range, FoundCell2 As Range
Dim Addr As String
Dim Addr2 As String
Dim SearchArea As Range
Dim SearchArea2 As Range

Application.ScreenUpdating = False
ActiveCell.Interior.ColorIndex = 0

'検索対象範囲
Set SearchArea = Worksheets("G番情報").Range("AE6:BG6")

'検索実行
Set FoundCell = SearchArea.Find(What:=myRange, LookIn:=xlValues, _
LookAt:=xlPart, MatchCase:=False, MatchByte:=False)

'検索文字列を含むセルがない場合は終了
If FoundCell Is Nothing Then Exit Sub

Set SearchArea2 = Range(FoundCell.Offset(0, 0), FoundCell.Offset(33, 0))
Set FoundCell2 = SearchArea2.Find(What:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchDirection:=xlNext, MatchCase:=False, MatchByte:=False)

If FoundCell2 Is Nothing Then Exit Sub

FoundCell2.Copy Destination:=ActiveCell
Application.ScreenUpdating = True

End Sub

投稿日時 - 2018-03-08 12:16:17

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.2

ざっくりとしかコードを見ていませんが

Worksheet_Change イベントで
PaintTargetCharacter を呼び出し

PaintTargetCharacter の処理の中で
FoundCell2.Copy Destination:=ActiveCell
を実行しているので、

いくつかのExit Sub にヒットしなかった場合、
(タブン、検索でヒットしたとき)に
ループに陥るんじゃないかと思います。

そもそもどのような処理をしたいのかと
シート構成、
更に提示されたコードをどのモジュールに配置しているのか
これらを説明し、
シートのイメージを提示してくれれば
もう少し突っ込んだコメントができるだろうと思います。

投稿日時 - 2018-03-08 20:57:47

補足

画像を追加致しました。
ご覧頂いてアドバイスをもらえたらと思います。

投稿日時 - 2018-03-09 07:58:23