エクセルのマクロで画像を貼り付け

質問

画像をエクセルに貼り付ける作業を行っています。
マクロを使いファイル内の画像（約３０枚程度）を１列づつスペースを空け
右方向に４枚
１行スペースを空け
３行目の左に戻り
その位置よりまた１列づつスペースを空け右方向に４枚・・・・・
これを繰り返しファイル内の画像をすべて
貼り付けたいのですがうまく動作が出来ません。
何卒ご教授の程よろしくお願いします。
※マクロ
Sub EggFunc_pasteDirImage()

' 変数定義
Dim fileName As String
Dim targetCol As Integer
Dim targetRow As Integer
Dim targetCell As Range
Dim shell, myPath
Dim pos As Integer
Dim extention As String
Dim isImage As Boolean

' 選択セルを取得
targetCol = ActiveCell.Column
targetRow = ActiveCell.Row

' フォルダ選択画面を表示
Set shell = CreateObject("Shell.Application")
Set myPath = shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, "C:\Users\0602116.MS\Desktop\")
Set shell = Nothing

' フォルダを選択したら...
If Not myPath Is Nothing Then

fileName = Dir(myPath.Items.Item.Path + "\")

Do While fileName <> ""

' ファイル拡張子の判別
isImage = True
pos = InStrRev(fileName, ".")
If pos > 0 Then
Select Case LCase(Mid(fileName, pos + 1))
Case "jpeg"
Case "jpg"
Case "gif"
Case Else
isImage = False
End Select
Else
isImage = False
End If

' 拡張子が画像であれば
If isImage = True Then

' 貼り付け先を選択
Cells(targetRow, targetCol).Select
Set targetCell = ActiveCell

' 画像読込み
ActiveSheet.Pictures.Insert(myPath.Items.Item.Path + "\" + fileName).Select

' 画像が大きい場合、画像サイズをセル幅に合わせる
If Selection.Width > targetCell.Width Or Selection.Height > targetCell.Height Then
If Selection.Width / targetCell.Width > Selection.Height / targetCell.Height Then
Selection.Height = Selection.Height * (targetCell.Width / Selection.Width)
Selection.Width = targetCell.Width
Else
Selection.Width = Selection.Width * (targetCell.Height / Selection.Height)
Selection.Height = targetCell.Height
End If
End If

' 表示位置をセル中央に移動
Selection.Top = targetCell.Top + (targetCell.Height - Selection.Height) / 2
Selection.Left = targetCell.Left + (targetCell.Width - Selection.Width) / 2

' 貼り付け先行を+1
targetCol = targetCol + 2

End If

fileName = Dir()
Loop

MsgBox "画像の読込みが終了しました"

End If

End Sub

回答No.1

watabe007 · ベストアンサー

>' 貼り付け先行を+1
> targetCol = targetCol + 2
' 貼り付け先行を+1
参考に
If targetCol >= 13 Then
　　targetCol = 7
　　targetRow = targetRow + 2
Else
　　targetCol = targetCol + 2
End If

お礼

ありがとうございます。
思っていた通りに動作しました。
この方法でのループできるのですね。
本当にありがとうございます。

回答No.2

imogasi

この質問も、質問にコードだけ上げて、＞「貼り付けたいのですがうまく動作が出来ません。」が、どううまくできないのか、文章での説明がない。
それがどううまくできないのか、説明するのが肝心ではないか。
読者・回答者に甘えて、長いVBAコードを読み解かす質問が多いが、他人の読者の手間を少なくすること。
また回答がピント外れにならないようにするためにもね。
ＶＢスクリプトを使う人が多いと思うが、使わなくても、ＶＢＡだけでできそうだが。（この質問もこれらしい。）
ーー
一案として、関心があれば、下記を参考にしてください。
（このほかにUserForm上やそのUserForm上のＩｍａｇｅなどのコントロールの上に画像を
貼りつける方法の方が、シートに貼りつけるよりも標準かもしれないけれど。）
どちらコントロールに張り付けるにしても
For j=1 to 4
For i=1 to 6
・・
のような仕組みでコントロールの位置を横Ｘ列、縦Ｙ行的に仕組む。
ーー
シートのセルの位置（Ｔｏｐ，Ｌｅｆｔ）や大きさ（Ｗｉｄｔｈ，Ｈｅｉｇｈｔ）を使って
位置の調整と大きさの調整ができるが、どうですか。
シートのセルを使うと配置の枠組みがしっかりする。多少の調整はむつかしいが。
たとえばＢ２、Ｄ２、Ｆ２、Ｈ２セルに画像を置き、第２列では、Ｂ４、Ｄ４、Ｆ４、Ｈ４に配置し、間１列や１行飛ばしているのは、この大きさを調整して間隔（多分等間隔）をあける意図です。
貼りつける方向はＺ字状に進める（Ｎ字状でない。この例えはわかりますか。）
具体的にセルを指定する方法をとれば、変な風な乱れはなくなる方法だと思う。
本件画像数が少ないので、こういう方法も取れるのですが。
ーー
下記は画像の配置に重点を置いたテストです。
下記は「同じ画像」が貼りつく（内容的には意味のない）テストですが、
その下記のループの外側を画像の入ったフォルダのファイル名を順次捕まえるFor　Each　・・・Nextで囲んでください。（またはＶＢＳＣｒｉｐｔを使わず、Ｄｉｒ関数利用する方法もあります。）
Sub test01()
Application.ScreenUpdating = False
'--貼りつける行と列指定のため指定
c = Array("", "B", "D", "F", "H")
r = Array(0, 2, 4, 6, 8, 10, 12)
'--画像ファイルファイル（フォルダ）
myFileName = "C:\Users\XXX\Pictures\PXXXXXX.jpg"
'--余白間隔にする行の行高設定
c1 = Array("", "A", "C", "E", "G")
'--余白行間隔
For j = 1 To 6
ActiveSheet.Rows(r(j) + 1).Select
Selection.RowHeight = 40
Next j
'--余白列間隔
For i = 1 To 4
ActiveSheet.Columns(c1(i)).Select
Selection.ColumnWidth = 5
Next i
'--画像貼り付け
For j = 1 To UBound(r)
For i = 1 To UBound(c)
'--セルの高さと幅指定
ActiveSheet.Rows(j).Select
Selection.RowHeight = 40
ActiveSheet.Columns(c(i)).Select
Selection.ColumnWidth = 10
'--シートに画像貼り付け
ActiveSheet.Range(c(i) & r(j)).Select
Set myShape = ActiveSheet.Shapes.AddPicture( _
Filename:=myFileName, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=Selection.Left, _
Top:=Selection.Top, _
Width:=Selection.Width, _
Height:=40)
Next i
Next j
Application.ScreenUpdating = True
End Sub
ーー
以下繰り返しテストには、下記が重宝するだろう。
Sub test02() '繰り返しテスト用のシートの全画像消去
ActiveSheet.DrawingObjects.Delete
With ActiveSheet.Range("a1:K100")
UseStandardHeight = True
UseStandardWidth = True
End With
End Sub
参考　SaveWithDocument:=True, でエラーが出たときの参考
http://blog.livedoor.jp/katsuyausami/archives/52167036.html

お礼

参考マクロありがとうございます。
質問内容が少なくて申し訳ありませんでした。
これを参考に勉強してみます。
本当にありがとうございます。