エクセルで写真挿入 マクロ

質問させて下さい。
エクセルで工事写真アルバムを作成したく、下記資料を参考にさせていただいたのですが・・・画像の挿入順番を変更するには、どうしたら良いのでしょうか？

※ActiveCell.Offset(5).Selectの部分を【順番】になるように


【順番】・・・画像１を任意セルに指定し複数の画像を右→下→右→下
　　　　　　（右には2セル移動　下には5セル移動）

　　A　　　B　　　C　　　D　　　E　　　F
1　　　　画像1　　　　　画像2
2
3
4　　　　画像3　　　　　画像4
5
6
7　　　　画像5　　　　　画像6
・
・
・　　　　・・・　　　　　　　・・・
・　
100






【資料】

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("C5").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

No.6 回答者： n_na_tto 回答日時： 2009/01/31 16:52

あの～～

これ以上補足することは何もないんですが。
No1の方法ではだめだったんですか？

この回答へのお礼

有難うございました。出来ました。
もっと、勉強してきます！！

お礼日時：2009/01/31 19:20

No.5 回答者： xls88 回答日時： 2009/01/31 13:18

取りあえず、回答番号：No.2のFor文を生かしてみました。

Sub test2()
　　Dim strFilter As String
　　Dim Filenames As Variant
　　Dim pic As Picture
　　Dim sc As Range
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long

　　'「ファイルを開く」ダイアログでファイル名を取得
　　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

　　'-順番に画像を挿入
　　Set sc = ActiveSheet.Range("B1") '挿入開始セル
　　For i = LBound(Filenames) To UBound(Filenames) / 2
　　　　For j = 0 To 2 Step 2
　　　　　　k = k + 1
　　　　　　Set pic = ActiveSheet.Pictures.Insert(Filenames(k))
　　　　　　With sc.Offset((i - 1) * 5, j)
　　　　　　　　pic.Top = .Top
　　　　　　　　pic.Left = .Left
　　　　　　End With
　　　　Next j
　　Next i

　　Set sc = Nothing: Set pic = Nothing
End Sub

この回答への補足

皆様　大変有難うございます。
それぞれに試行錯誤行ってみました。超初心者なもので・・・・もうちょっとのところなのですが、知識が乏しく・・・
大変ご迷惑かと思いますが。仕事の都合上、時間がなく

単刀直入に教えて頂けたら、幸いです。

【やりたい事】

(1)任意のセルより写真を複数挿入
(2)挿入順番は　任意セル→2列先→任意セル5段下→以下同順番
(3)写真の大きさは挿入時にセルの高さに合わせる（結合セルの場合でも対応）
(4)挿入位置はセルの上側に重ねる・左側に重ねる
(5)挿入後、「何枚写真挿入しました」メッセージ


本当に申し訳ございませんが、知恵を下さい。

補足日時：2009/01/31 15:28

この回答へのお礼

有難うございました。出来ました。
もっと、勉強してきます！！

お礼日時：2009/01/31 19:22

No.4 回答者： n_na_tto 回答日時： 2009/01/31 13:05

No.2さんのおっしゃるとおりSelect等不要なんですが...

Dim myRng As Range
Set myRng = ActiveCell

として
ActiveCell.　→myRng.
にすべて置き換え、
最後のほうを

Select Case i Mod 2
Case 1 '奇数回目
Set myRng = myRng.Offset(, 2)
Case 0 '偶数回目
Set myRng = myRng.Offset(5, -2)
End Select

にする..。
面倒でなければどうぞ。

No.3 回答者： xls88 回答日時： 2009/01/31 12:18

回答番号：No.2 のコードは確認不足でした。

役に立ちません。
見直してから、再投稿します。
大変失礼しました。

No.2 回答者： xls88 回答日時： 2009/01/31 10:24

写真挿入に関係する部分のみですが一例をあげます。

貼り付けセルをSelectとか、Activateする必要はありません。

　　Dim sc As Range
　　Dim i As Long
　　Dim j As Long

　　Set sc = ActiveSheet.Range("B1") '貼り付け開始セル
　　For i = 1 To 10
　　　　Set pic = ActiveSheet.Pictures.Insert(Filenames(i))
　　　　For j = 0 To 2 Step 2
　　　　　　With sc.Offset((i - 1) * 5, j)
　　　　　　　　pic.Top = .Top
　　　　　　　　pic.Left = .Left
　　　　　　End With
　　　　Next j
　　Next i

回答で得られたコードは、必ず読み解き、理解する努力をしてください。そのうち応用ができるようになります。

No.1 回答者： n_na_tto 回答日時： 2009/01/31 05:04

コードを書かれた方、申し訳ありません。

' 次の貼り付け先を選択～の次の1行を
下の6行に変えたらどうでしょうか。

　　　　Select Case i Mod 2
　　　　　Case 1 '奇数回目
　　　　　　ActiveCell.Offset(, 2).Select
　　　　　Case 0 '偶数回目
　　　　　　ActiveCell.Offset(5, -2).Select
　　　　End Select