VBAで同じ作業を２回繰り返す場合のコード

質問

下記コードで具体的アドバイスを頂ければと思います。よろしくお願いいたします。

■やりたいこと
EXCELのシートに、２種類の写真表示スペースを作って、そのそばでそれぞれファイル名を入力して、そのファイル名を変えるごとに、それぞれのjpegファイルを表示させたい。

■質問
下記コードで、ふたつめの変数を変えればよいことは、分かるのですが、どこをどのようにして、変数を変えればいいかわかりません。ご教授お願いします。

■私の作っているコード
とあるサイトを参考にして、下記作成いたしました。
'ひとつめ写真表示
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fName As String, pict As Shape
If Target.Address <> "$H$25" Then Exit Sub

fName = ThisWorkbook.Path & "\board_Image\" & Target.Offset(0, 0).Text

If Dir(fName) = "" Then
fName = ThisWorkbook.Path & "\board_Image\NoImage.jpg"
End If

With ActiveSheet
For Each pict In .Shapes
If pict.TopLeftCell.Address = "$C$26" Then
pict.Delete
Exit For
End If

Next pict
Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
.Range("k6").Left, .Range("C26").Top, 260, 320)
End With
End Sub

-----------------------------------------------------------------------------
'ふたつめ写真表示
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fName As String, pict As Shape
If Target.Address <> "$AT$4" Then Exit Sub

fName = ThisWorkbook.Path & "\map_Image\" & Target.Offset(0, 0).Text

If Dir(fName) = "" Then
fName = ThisWorkbook.Path & "\map_Image\NoImage.jpg"
End If

With ActiveSheet
For Each pict In .Shapes
If pict.TopLeftCell.Address = "$k$6" Then
pict.Delete
Exit For
End If

Next pict
Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
.Range("k6").Left, .Range("k6").Top, 260, 320)
End With
End Sub

回答No.5

mitarashi · ベストアンサー

#2,4です。
>新たなイベントを用意して、やれば、いいということですね。
イベントに対する処理を下請けに出しているだけで、新たなイベントという訳ではありません。

>loadpicture(myはいりますかね？）
ユーザーフォームに画像を読みこむloadpictureというVBAの機能がありますので、それと区別するためにmyをつけています。

>さらに別フォルダでもう一箇所写真表示箇所を増やそうと思ったら、どういう関数が使えますでしょうか？
下記の通り、お好きなだけ場合分けを追加していただければ結構です。
「どういう関数を使う」という訳ではなくて、自分で定義した関数（正確な表現ではありませんが、便宜上）に渡す引数を変えて、何度でも呼び出してやれば良いです。これが、繰り返し作業を関数にまとめるメリットです。
以上、ご参考まで。
Select Case Target.Address
Case "$H$25"
myLoadPicture "board_Image", Target.Text, Range("C26")
Case "$AT$4"
myLoadPicture "map_Image", Target.Text, Range("K6")
Case "$A$50"
myLoadPicture "hoge_Image",Target.Text,Range("A100")
Case "$B$1"
myLoadPicture .....
（以下、お好きなだけ追加）
Case Else
Exit Sub
End Select

お礼

無知な私の度重なる質問に答えていただき、ありがとうございました。

じっくりと拝見させていただき。なんとか理解できました。

汎用性、応用も利く、とても素晴らしいコードだと思います。私は本当に幸運です。

本当にありがとうございました。

回答No.4

mitarashi

#2です。フォルダー名の相違は見落としておりました。（試運転でエラーが出ておかしいなとは思ったのですが、詰めが甘かった．．．）
別関数にしているので、こういう仕様の変更（オイオイ、見落としておいて）への対処は楽かもしれません。
Private Sub Worksheet_Change(ByVal Target As Range)
Select Case Target.Address
Case "$H$25"
myLoadPicture "board_Image", Target.Text, Range("C26")
Case "$AT$4"
myLoadPicture "map_Image", Target.Text, Range("K6")
Case Else
Exit Sub
End Select
End Sub

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

お礼

なるほど、Worksheet_Changeが使えない代わりに、loadpicture(myはいりますかね？）という、新たなイベントを用意して、やれば、いいということですね。

未熟な私にも分かりやすかったです。ありがとうございます。

さらにずうずうしく質問ばっかりで、ごめんなさい。さらに別フォルダでもう一箇所写真表示箇所を増やそうと思ったら、どういう関数が使えますでしょうか？

差し支えなければ、教えていただければ幸いです。

回答No.3

keithin

まず，２つのセル用のマクロを２つ並べて記載しても動かないので，「両方の」マクロを消します。
次のマクロに差し替えます。

private sub worksheet_change(byval Target as excel.range)
　dim fName as string
　dim h0 as Range, h as range

’記入セルを必要に応じて直すこと
　set h0 = application.intersect(target, range("H25,AT4"))
　if h0 is nothing then exit sub

　on error resume next
　for each h in h0
　　fname = thisworkbook.path & "\board_Image\" & h.text
　　ff dir(fname) = "" Then
　　　fname = thisworkbook.path & "\board_Image\NoImage.jpg"
　　end if

　　activesheet.shapes("pict_" & h.address).delete

　　if h <> "" Then
　’画像の配置位置・大きさは必要に応じて直すこと
　　activesheet.shapes.addpicture(fname, msotrue, msofalse, _
　　range("k6").left, _
　　range(iif(h.address = "$H$25", "K26", "K6")).top, _
　　260, 320).name = "pict_" & h.address
　　end if
　next
end sub

＃補足
今のマクロはアタリマエのように一つのセルに入力する事を想定していますが，必ずしもそうとは限らないので対処します。
セルの記入内容を削除したときの動作も少し直しています

お礼

回答ありがとうございます。
こんなにたくさんの方の有識者にアドバイスいただけてとても幸せです。皆様本当にありがとうございます。

keithin様
一番短くて、分かりやすそうなプログラムだったのですが、残念ながらコンパイルエラーが出てしまいました。
そして自分で直そうとしまいましたが、直せませんでした。
甘えてばっかりで恐縮ですが、ご確認頂ければ幸いです。

回答No.2

mitarashi

If pict.TopLeftCell.Address = "$C$26"
で判断して、既存の画像を削除している事から、下記の"k6"は誤りと判断させていただきました。
Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse,.Range("k6").Left, .Range("C26").Top, 260, 320)
それを前提としたコードです。ご参考まで。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim fname As String

If Target.Address <> "$H$25" And Target.Address <> "$AT$4" Then Exit Sub
fname = ThisWorkbook.Path & "\board_Image\" & Target.Text
If Dir(fname) = "" Then
fname = ThisWorkbook.Path & "\board_Image\NoImage.jpg"
End If
Select Case Target.Address
Case "$H$25"
myLoadPicture fname, Range("C26")
Case "$AT$4"
myLoadPicture fname, Range("K6")
End Select
End Sub

Private Sub myLoadPicture(fname As String, targetRange As Range)
Dim pict As Shape

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(fname, msoTrue, msoFalse, _
targetRange.Left, targetRange.Top, 260, 320)
End With
End Sub

お礼

mitarashi様

回答ありがとうございました。
ご提示いただいたプログラムで写真はうまく表示できました。すごくありがたいです。

※但し、ＮＯ１の回答者様と同じで恐縮なのですが、
写真を格納するファイルですが「board_Image」と「map_Image」があり、出来れば、一つ目と二つ目から、それぞれのフォルダへ読み込めるようにしたいのですが、ここもプログラムに反映する方法を教えていただければと思います。

回答No.1

jcctaira

puyopaさん　こんにちは。

ワークシートイベントは１つしか指定できません。
Private Sub Worksheet_Change(ByVal Target As Range)

よって、Targetの内容により場合分けして処理をすればよいです。
・Targetが$H$25の時
・Targetが$K$6の時
・それ以外の時

また、プログラムの修正は「ひとつめ写真表示」と「ふたつめ写真表示」の違う部分を
変数化にすれば良いです。

puyopaさんのプログラムを変更したサンプルです。
※テストはしていませんので、内容を再度確認してください。

Private Sub Worksheet_Change(ByVal Target As Range)
　Dim fName As String, pict As Shape
　Dim Topセル As String
　Select Case Target.Address
　　Case "$H$25"
　　　Topセル = "$C$26"
　　Case "$AT$4"
　　　Topセル = "K$6$"
　　Case Else
　　　Exit Sub
　End Select
　fName = ThisWorkbook.Path & "\board_Image\" & Target.Offset(0, 0).Text
　If Dir(fName) = "" Then
　　fName = ThisWorkbook.Path & "\board_Image\NoImage.jpg"
　End If
　With ActiveSheet
　　For Each pict In .Shapes
　　　If pict.TopLeftCell.Address = Topセル Then
　　　　pict.Delete
　　　　Exit For
　　　End If
　　Next pict
　　Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
　　　　.Range("K6").Left, .Range(Topセル).Top, 260, 320)
　End With
End Sub

お礼

jcctaira様
早速の回答ありがとうございます。大変ありがたいです。おかげさまでイベントプロシージャをひとつにまとめるという所はなんとか理解できました。
甘えてばっかりで、恐縮なのですが、もう２点質問させてください。

（１点目）
回答者様がご提示いただいた
最後から３~４行目で「アプリケーション定義またはオブジェクト定義のエラーです。」とエラーが出るのですが、どこが誤りか自分では見つけられませんでした。教えていただければ幸いです。

　　Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
　　　　.Range("K6").Left, .Range(Topセル).Top, 260, 320)

（２点目）
写真を格納するファイルですが「board_Image」と「map_Image」があり、出来れば、一つ目と二つ目から、それぞれのフォルダへ読み込めるようにしたいのですが、ここもプログラムに反映する方法を教えていただければと思います。

甘えてばっかりで恐縮ですが、よろしくお願いいたします。