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("Ｇ番情報").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)
の部分でエラーが起きてしまいます。
また停止してシートに戻るとセルのカーソル表示が消えてしまいます。
この現象はシートを閉じて再度開くと直りますが
なにかエラーと関係しているのでしょうか？

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

回答No.1

tsubu-yuki · ベストアンサー

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

> 入力後エンターキーを押すとアクティブセルは下に下がってしまう
> 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を使わずに処理を進められます。

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

補足

ありがとうございます。頂いたコードをもとに下記のようにやってみましたが、機能しませんでした。
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("Ｇ番情報").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

回答No.2

HohoPapa

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

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

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

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

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

補足

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