excel VBA ２つのプロシージャを１つに

質問

いつもお世話になっております。

初心者ですが、苦しみながらもexcelでデータベースを作成しております。

さて Worksheet_Change　のイベントが２つあり、これを一つにまとめようとしているのですが、がんばっているんですが、自分ではどうしてもうまくいかない為、投稿させていただきました。

コードは下記２つです。
また、どういったものを作ろうとしているのか説明不足でご指摘を頂戴することもありますので、試作段階のファイルですが、アップローダーにあげさせていただきました。確認頂ければ幸いです。

■アプロダ 投稿No 4514
http://www.kent-web.com/pubc/book/test/uploader/uploader.cgi

■作ろうとしているデータベースの概要
inputシート・・・データを直接入力して、また、データや写真を閲覧をするシート
dataシート・・・データを格納するシート、オートフィルタを使って、曖昧検索フィルタもここでかけたりします。

どうか良いお知恵を拝借させていただきたくよろしくお願いします。

'一つ目のプロシージャ（Noセルに数字が入ると、そのNoのデータを自動的にdataシートまで読みにいって表示させます）

Private Sub WorkSheet_Change(ByVal Target As Range)
'No入力してデータ反映
Dim fRange As Range
Dim fRow As Long

If Target.row <> 4 Then Exit Sub
If Target.Column <> 3 Then Exit Sub

Set fRange = Sheets("data").Columns(1).Find(What:=Range("C4").Value, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)

If (fRange Is Nothing) Then '見つからなかった？
MsgBox "入力された顧客コードが存在しません。", vbExclamation
Exit Sub
End If

fRow = fRange.row '検索された顧客DCの行位置を求める
Range("F4").Value = Sheets("data").Cells(fRow, 2).Value
Range("C5").Value = Sheets("data").Cells(fRow, 3).Value
Range("C6").Value = Sheets("data").Cells(fRow, 4).Value
Range("C7").Value = Sheets("data").Cells(fRow, 5).Value
Range("F5").Value = Sheets("data").Cells(fRow, 6).Value

End Sub

'二つ目のプロシージャ（写真を表示させるためのコードです）

Private Sub Worksheet_Change(ByVal Target As Range)
Select Case Target.Address
Case "$k$4"
myLoadPicture "board_Image", Target.Text, Range("I5")
Case "$K$17"
myLoadPicture "map_Image", Target.Text, Range("I18")
Case Else
Exit Sub
End Select
End Sub

回答No.2

keithin · ベストアンサー

＞片方の絵が出ない

その部分はあなたの元のご相談マクロから変えてないので，今回の修正は無関係です。つまり元々間違ってました。

間違い：
Case "$k$4"

正解：
Case "$K$4"

＞エラー

そこも同じで元々間違ってた部分ですが，片方の絵は出ると言うことだと，シートに記入してあるデータなどに誤記があるんじゃないかと思います。
ファイル名やフォルダ名など，よく再確認してください。

エラーが出たときは，黄色くなった行の各部の内容を一つずつ漏れなくよくよくよく精査して，何が間違っているのかしっかり突き詰めてください。こういうのを「デバッグ」と言って，マクロを作成する時には必ず行わないとダメです。
たとえば
VBE画面でローカルウィンドウを出しておき，各変数の値をよくチェックします。
イミディエイトウィンドウで変数の値を調べたり，記載を変えたマクロを実行して動作を再確認します。

お礼

ご指導ありがとうございます。自分でちゃんと調べないといけないことなのに甘えてしまって反省しております。イミディエイトウィンドウを使って自分でも間違いが探せるように精進いたします。
色々とありがとうございました。

回答No.1

keithin

Private Sub Worksheet_Change(ByVal Target As Range)
Dim fRange As Range
Dim fRow As Long

Select Case Target.Address

case "$C$4"
Set fRange = Sheets("data").Columns(1).Find(What:=Range("C4").Value, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)

If (fRange Is Nothing) Then '見つからなかった？
MsgBox "入力された顧客コードが存在しません。", vbExclamation
Exit Sub
End If

fRow = fRange.row '検索された顧客DCの行位置を求める
Range("F4").Value = Sheets("data").Cells(fRow, 2).Value
Range("C5").Value = Sheets("data").Cells(fRow, 3).Value
Range("C6").Value = Sheets("data").Cells(fRow, 4).Value
Range("C7").Value = Sheets("data").Cells(fRow, 5).Value
Range("F5").Value = Sheets("data").Cells(fRow, 6).Value

Case "$k$4"
myLoadPicture "board_Image", Target.Text, Range("I5")
Case "$K$17"
myLoadPicture "map_Image", Target.Text, Range("I18")
Case Else
Exit Sub
End Select
End Sub

でいいです。

お礼

迅速な回答助かります、ありがとうございました。

早速、ためさせて頂いたところ、
なぜか写真が一つだけ表示されて(map_Image)、もう一方の写真は表示されませんでした。
また、写真のディレクトリを指定するコードのset pictという部分でエラーが出るようになってしまいました。
これは今回の修正とは、何か関係がありそうでしょうか？もしあるようでしたら、またアドバイスを頂ければ幸いです。ついでの質問ですみません。

'以下 写真のディレクトリを指定するコードです
Private Sub myLoadPicture(folderName As String, fname As String, targetRange As Range)
Dim pict As Shape, picPath As String

picPath = ThisWorkbook.Path & "\" & folderName & "\" & fname
If Dir(picPath) = "" Then

picPath = ThisWorkbook.Path & "\" & folderName & "\" & "NoImage.jpg"
End If

With ActiveSheet
For Each pict In .Shapes
If pict.TopLeftCell.Address = targetRange.Address Then
pict.Delete
Exit For
End If

Next pict
Set pict = .Shapes.AddPicture(picPath, msoTrue, msoFalse, _
targetRange.Left, targetRange.Top, 260, 320)
End With
End Sub