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
のセルに貼り付けという具合にしたいです。
よろしくお願いします。
お礼
有難うございます。 回答の通りで出来ました。 また、参考リンクも教えて頂き、大変参考になりました。 ときどき分からないことがあれば質問しており、とても助かっています。 今後とも、宜しくお願いします。