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
のセルに
【123】という数字が混じっていたら
ElseIf ActiveCell.Column = 10 Then
ActiveCell.Offset(, 8).Select
のセルに貼り付けという具合にしたいです。
よろしくお願いします。
お礼
ありがとうございます。 このような書き方をするんですね。 また一つ勉強になりました。 ありがとうございました。