【マクロ】Excelでコンタクトシートを作成

Excelを用いコンタクトシートのような配列で
画像を挿入（複数）させるマクロを作成したいのですが
「縦５枚×横３枚」のような配列にする時に
「横３枚」挿入させる方法がわかりません。
ご教授お願い申し上げます。


Ｑ：下記のような配列で画像を挿入するには？
-------------------------------------------
　　　A　　　B　　　C　　　D　　　E　　　F
1 　　　　01.jpg　　　　02.jpg　　　　03.jpg
2
3 　　　　04.jpg　　　　05.jpg　　　　06.jpg
4
5 　　　　07.jpg　　　　08.jpg　　　　09.jpg
6
7 　　　　10.jpg　　　　11.jpg　　　　12.jpg
8
9 　　　　13.jpg　　　　14.jpg　　　　15.jpg
10
　　　　　　　---次ページ---
11　　　　16.jpg　　　　17.jpg　　　　18.jpg
12
13　　　　19.jpg　　　　20.jpg　　　　21.jpg
14
15　　　　22.jpg　　　　23.jpg　　　　24.jpg
16
17　　　　25.jpg　　　　26.jpg　　　　27.jpg
18
19　　　　28.jpg　　　　29.jpg　　　　30.jpg
20
　　　　　　　---次ページ---
21　　　　31.jpg　　　　32.jpg　　　　33.jpg
22
23　　　　34.jpg　　　　35.jpg　　　　36.jpg
24
25　　　　37.jpg　　　　38.jpg　　　　39.jpg
・
・
・
・
-------------------------------------------


※画像挿入のマクロに関してはこちら↓の質問を参考にしています。
　質問番号：4676078
　「エクセルで写真挿入　マクロ」
　http://oshiete1.goo.ne.jp/qa4676078.html
※画像はJPG形式に限りません。（BMP、GIF等も）
※コンタクトシート作成ソフトは使いませんので
　必ずExcelでマクロを使用する方法をご回答願います。

No.2 ベストアンサー 回答者： fujillin 回答日時： 2009/05/26 21:26

ご提示のコードだと、スタートセル（Ｃ4）から順に次のセルを決めて行く方式ですので、わざわざ行・列を計算しなくても、次のセルの位置を指定すればよくなっていますね。

現在のセルに対して次のセルは、基本的には右へ2列なので
　ActiveCell.Offset(0,2).Select
となりますし、もし現在のセルがE列より右なら（折り返すので）
　ActiveCell.Offset(2,-4).Select
みたいになります。

両方を合わせれば
　Ｉｆ　ActiveCell.column>5 then ActiveCell.offset(0,2).select else AitiveCell.Offset(2,-4).select
で次のセルが決まるのでは？

この回答への補足

ご回答ありがとうございます。
詳しいご回答を頂いたのですが、コードをうまく実行できず
「横３枚」まで行かず、「横２枚」で折り返してしまいます。
何度も申し訳ございませんが、現在は以下のコードとなっていますので
再度ご教授お願い申し上げます。


Sub 複数の画像を挿入()

Dim strFilter As String
Dim Filenames As Variant
Dim PIC As Picture

' 「ファイルを開く」ダイアログでファイル名を取得
strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
Filenames = Application.GetOpenFilename( _
FileFilter:=strFilter, _
Title:="図の挿入(複数選択可）", _
MultiSelect:=True)
If Not IsArray(Filenames) Then Exit Sub

' ファイル名をソート
Call BubbleSort_Str(Filenames, True, vbTextCompare)

' 貼り付け開始セルを選択
'ActicveCellRange("B4").Select


' マクロ実行中の画面描写を停止
Application.ScreenUpdating = False
' 順番に画像を挿入
For i = LBound(Filenames) To UBound(Filenames)
Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))

'-------------------------------------------------------------
' 画像の各種プロパティ変更
'-------------------------------------------------------------
With PIC
.Top = ActiveCell.Top ' 位置：アクティブセルの上側に重ねる
.Left = ActiveCell.Left ' 位置：アクティブセルの左側に重ねる
.Placement = xlMove ' 移動するがサイズ変更しない
.PrintObject = True ' 印刷する
End With
With PIC.ShapeRange
.LockAspectRatio = msoTrue ' 縦横比維持
' 画像の高さをアクティブセルにあわせる
' 結合セルの場合でも対応
.Height = ActiveCell.MergeArea.Height
End With

' 次の貼り付け先を選択（アクティブセルにする）[例：6個下のセル]
Select Case i Mod 2
Case 1 '奇数回目
ActiveCell.Offset(0, 2).Select
Case 0 '偶数回目
ActiveCell.Offset(9, -2).Select
End Select

Set PIC = Nothing
Next i

' 終了
Application.ScreenUpdating = True
MsgBox i - 1 & "枚の画像を挿入しました", vbInformation

End Sub

' バブルソート（文字列）
Private Sub BubbleSort_Str( _
ByRef Source As Variant, _
Optional ByVal SortAsc As Boolean = True, _
Optional ByVal Compare As VbCompareMethod = vbTextCompare)

If Not IsArray(Source) Then Exit Sub

Dim i As Long, j As Long
Dim vntTmp As Variant
For i = LBound(Source) To UBound(Source) - 1
For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1
If StrComp(Source(IIf(SortAsc, j, j + 1)), _
Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then
vntTmp = Source(j)
Source(j) = Source(j + 1)
Source(j + 1) = vntTmp
End If
Next j
Next i

End Sub

補足日時：2009/05/27 11:23

この回答へのお礼

補足

【使用環境】
Microsoft Windows XP Professional
Microsoft Office Excel 2003 SP3
Microsoft Visual Basic 6.5

お礼日時：2009/05/27 12:01

No.1 回答者： fujillin 回答日時： 2009/05/26 14:28

例えば全体をループで回していると仮定して、i番目の画像をどこに配置するかを対応できれば良いですよね？

質問文に合わせるなら、列はB、D、Fの順（偶数列）、行は1、3、5（奇数行）…が対象となっているとして

i のループが1から始まると仮定すれば、i番に対応する行番号、列番号は
　行番号 = Int((i - 1) / 3) * 2 + 1
　列番号 = ((i - 1) Mod 3 + 1) * 2
で求められますので、そこに貼り付けるようにすればよいのでは？
（iのスタートを0からにする方が、対応式は簡単になります）

逆に、行番号、列番号から対応するインデックス番号(=i）を求めるには
　i = ((rw-1)*3+col)/2　(rw:行番号、col:列番号）
となります。

対象となる行や列が違う場合でも、対応関係が規則的なら読み替えの式が作成できるはずですので、このような式を元に対応させてゆくのが簡単化と思います。

この回答への補足

ご回答頂きありがとうございました。
大変お恥ずかしい話ですが、ご教授頂いたコードを
どの位置に貼り付ければ良いのか検討がつきません。
お手数をお掛けして申し訳ございませんが
下記のコードに当てはめご回答頂ければ頂けれ幸いです。
宜しくお願い申し上げます。


Sub 複数の画像を挿入()

Dim strFilter As String
Dim Filenames As Variant
Dim PIC As Picture

' 「ファイルを開く」ダイアログでファイル名を取得
strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
Filenames = Application.GetOpenFilename( _
FileFilter:=strFilter, _
Title:="図の挿入(複数選択可）", _
MultiSelect:=True)
If Not IsArray(Filenames) Then Exit Sub

' ファイル名をソート
Call BubbleSort_Str(Filenames, True, vbTextCompare)

' 貼り付け開始セルを選択
'ActicveCellRange("C4").Select


' マクロ実行中の画面描写を停止
Application.ScreenUpdating = False
' 順番に画像を挿入
For i = LBound(Filenames) To UBound(Filenames)
Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))

'-------------------------------------------------------------
' 画像の各種プロパティ変更
'-------------------------------------------------------------
With PIC
.Top = ActiveCell.Top ' 位置：アクティブセルの上側に重ねる
.Left = ActiveCell.Left ' 位置：アクティブセルの左側に重ねる
.Placement = xlMove ' 移動するがサイズ変更しない
.PrintObject = True ' 印刷する
End With
With PIC.ShapeRange
.LockAspectRatio = msoTrue ' 縦横比維持
' 画像の高さをアクティブセルにあわせる
' 結合セルの場合でも対応
.Height = ActiveCell.MergeArea.Height
End With

' 次の貼り付け先を選択（アクティブセルにする）[例：5個下のセル]
ActiveCell.Offset(5).Select

Set PIC = Nothing
Next i

' 終了
Application.ScreenUpdating = True
MsgBox i - 1 & "枚の画像を挿入しました", vbInformation

End Sub

' バブルソート（文字列）
Private Sub BubbleSort_Str( _
ByRef Source As Variant, _
Optional ByVal SortAsc As Boolean = True, _
Optional ByVal Compare As VbCompareMethod = vbTextCompare)

If Not IsArray(Source) Then Exit Sub

Dim i As Long, j As Long
Dim vntTmp As Variant
For i = LBound(Source) To UBound(Source) - 1
For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1
If StrComp(Source(IIf(SortAsc, j, j + 1)), _
Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then
vntTmp = Source(j)
Source(j) = Source(j + 1)
Source(j + 1) = vntTmp
End If
Next j
Next i

End Sub

補足日時：2009/05/26 18:36

この回答へのお礼

ご回答頂きありがとうございました。
その後いろいろ試行しながら貼り付け先を調整して
無事に解決しました。
ありがとうございました。
（入力欄が前後してしまい申し訳ございません。）


' 次の貼り付け先を選択（アクティブセルにする）
Select Case i Mod 3
Case 2
ActiveCell.Offset(0, 2).Select
Case 1
ActiveCell.Offset(0, 2).Select
Case 0
ActiveCell.Offset(9, -5).Select
End Select

お礼日時：2009/05/27 19:38