VBAで特定の文字が含まれている画像ファイル

質問

下記コードで画像の貼り付けを行っていますが
現在は適当な順番で貼り付けが行われます。
Declare Function SetCurrentDirectory Lib "kernel32" Alias _
"SetCurrentDirectoryA" (ByVal CurrentDir As String) As Long

Sub ShapeLoadtest()
Dim Fname As Variant, fe As Variant
Dim Fn As Variant, Pic As Shape
Dim pno As Long
Dim myFileName As String
Dim strFileName As String

Range("B4").Select

SetCurrentDirectory "C:\Users\yuya\Desktop\画像\"

Fname = Application.GetOpenFilename _
(",*", MultiSelect:=True)
If Not IsArray(Fname) Then
MsgBox "取り消されました。", vbInformation
Exit Sub
End If

Application.ScreenUpdating = False

pno = 0

For Each Fn In Fname
'この次へ追加すべき行
Selection.Offset(-1, 0) = Mid(Fn, InStrRev(Fn, "\") + 1, Len(Fn) - InStrRev(Fn, "\"))

ActiveCell.Select
Set Pic = ActiveSheet.Shapes.AddPicture(Filename:=Fn, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=0, Top:=0, Width:=0, Height:=0)

With Pic
.ScaleWidth 1, msoTrue
.ScaleHeight 1, msoTrue

.Top = ActiveCell.Top ' 位置：アクティブセルの上側に重ねる
.Left = ActiveCell.Left ' 位置：アクティブセルの左側に重ねる
.Placement = xlMove ' 移動するがサイズ変更しない
End With

If ActiveCell.Column = 2 Then
ActiveCell.Offset(, 8).Select
ElseIf ActiveCell.Column = 10 Then
ActiveCell.Offset(, 8).Select
ElseIf ActiveCell.Column = 18 Then
ActiveCell.Offset(32, -16).Select
End If

Set Pic = Nothing

pno = pno + 1
Next

Application.ScreenUpdating = True

Range("A1").Select
MsgBox pno & "枚の画像を挿入しました", vbInformation

End Sub

これを画像ファイル名に【あいう】という文字が混じっていたら
If ActiveCell.Column = 2 Then
ActiveCell.Offset(, 8).Select
のセルに
【１２３】という数字が混じっていたら
ElseIf ActiveCell.Column = 10 Then
ActiveCell.Offset(, 8).Select
のセルに貼り付けという具合にしたいです。

よろしくお願いします。

回答No.1

HohoPapa · ベストアンサー

こんな感じでしょうか。

Option Explicit

Declare Function SetCurrentDirectory Lib "kernel32" Alias _
"SetCurrentDirectoryA" (ByVal CurrentDir As String) As Long

Sub ShapeLoadtest1()
　Dim Fname As Variant, fe As Variant
　Dim Fn As Variant, Pic As Shape
　Dim pno As Long
　Dim myFileName As String
　Dim strFileName As String

　Dim PutCell As Range
　SetCurrentDirectory "D:\Test\"

　Fname = Application.GetOpenFilename _
　　(",*", MultiSelect:=True)
　If Not IsArray(Fname) Then
　　MsgBox "取り消されました。", vbInformation
　　Exit Sub
　End If

　Application.ScreenUpdating = False

　pno = 0

　For Each Fn In Fname
　'この次へ追加すべき行

　　With ThisWorkbook.Sheets(1)
　　　If InStr(Fn, "あいう") > 0 Then
　　　　Set PutCell = ThisWorkbook.Sheets(1).Cells(2, 10)
　　　ElseIf InStr(Fn, "１２３") > 0 Then
　　　　Set PutCell = ThisWorkbook.Sheets(1).Cells(2, 16)
　　　End If
　　End With

　　PutCell.Offset(-1, 0) = Mid(Fn, InStrRev(Fn, "\") + 1, Len(Fn) - InStrRev(Fn, "\"))

　　Set Pic = ActiveSheet.Shapes.AddPicture(Filename:=Fn, _
　　LinkToFile:=False, _
　　SaveWithDocument:=True, _
　　Left:=0, Top:=0, Width:=0, Height:=0)

　　With Pic
　　　.ScaleWidth 1, msoTrue
　　　.ScaleHeight 1, msoTrue

　　　.Top = PutCell.Top ' 位置：アクティブセルの上側に重ねる
　　　.Left = PutCell.Left ' 位置：アクティブセルの左側に重ねる
　　　.Placement = xlMove ' 移動するがサイズ変更しない
　　End With

　　Set Pic = Nothing

　　pno = pno + 1
　Next

　Application.ScreenUpdating = True

　Range("A1").Select
　MsgBox pno & "枚の画像を挿入しました", vbInformation

End Sub

お礼

まさに望み通りのことができました。
ありがとうございました。

回答No.2

HohoPapa

'//----------------------先ほど提示したコード
　'この次へ追加すべき行
　　With ThisWorkbook.Sheets(1)
　　　If InStr(Fn, "あいう") > 0 Then
　　　　Set PutCell = ThisWorkbook.Sheets(1).Cells(2, 10)
　　　ElseIf InStr(Fn, "１２３") > 0 Then
　　　　Set PutCell = ThisWorkbook.Sheets(1).Cells(2, 16)
　　　End If
　　End With

'//----------------------↑を以下、ちょっと修正します。　m(_ _)m
　'この次へ追加すべき行
　　With ThisWorkbook.Sheets(1)
　　　If InStr(Fn, "あいう") > 0 Then
　　　　Set PutCell = .Cells(2, 10)
　　　ElseIf InStr(Fn, "１２３") > 0 Then
　　　　Set PutCell = .Cells(2, 18)
　　　Else
　　　　Set PutCell = .Cells(2, 4)
　　　End If
　　End With