【マクロ】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 · ベストアンサー

ご提示のコードだと、スタートセル（Ｃ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
で次のセルが決まるのでは？

お礼

補足

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

補足

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

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

回答No.1

fujillin

例えば全体をループで回していると仮定して、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:列番号）
となります。

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

お礼

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

' 次の貼り付け先を選択（アクティブセルにする）
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

補足

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

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