[[20221125170236]]　『画像を交互に2種類の指定行へ貼り付けする』（ドナセラ）　ページの最後に飛ぶ

『画像を交互に2種類の指定行へ貼り付けする』（ドナセラ）

お世話になります。
VBA初心者です。

複数の画像をファイル名順に貼り付けしたく、
過去ログを参考にコードを作成しております。

（1）1枚目の画像を貼り付け

（2）2枚目の画像を（1）の3行下のセルに貼り付け

（3）3枚目の画像を（2）の6行下のセルに貼り付け

（4）4枚目の画像を（3）の3行下のセルに貼り付け
　・
　・
　・

といった具合に3行下と6行下への貼り付けを交互に行いたいのですが苦戦しております。

どなたかご教授いただけますでしょうか？
よろしくお願いいたします。

Option Explicit

 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)

    Dim fName As Variant
    Dim i As Long
    Dim Pict As Picture
    Dim r As Range

    fName = Application.GetOpenFilename("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", MultiSelect:=True)
    If IsArray(fName) Then
        Application.ScreenUpdating = False
        '配列に格納されたファイル名をソート
        BubbleSort fName, True
            Set r = ActiveCell.MergeArea

    For i = 1 To UBound(fName)
        With ActiveSheet.Shapes.AddPicture( _
                    Filename:=fName(i), _
                    LinkToFile:=False, SaveWithDocument:=True, _
                    Left:=r.Left, Top:=r.Top, _
                    Width:=-1, Height:=-1)
                .Height = 275
                '.Width =
                .Top = r.Top + (r.Height - .Height) / 2
                .Left = r.Left + (r.Width - .Width) / 2

        End With
        Set r = r.Offset(3).MergeArea
    Next i
    End If
    With Application
        .StatusBar = False
        .ScreenUpdating = True
    End With
    Set Pict = Nothing
    If i < 1 Then
    MsgBox "0枚の画像を挿入しました", vbInformation

    Else
    MsgBox i - 1 & "枚の画像を挿入しました", vbInformation
    End If

End Sub

'値の入替え
Public Sub Swap(ByRef Dat1 As Variant, ByRef Dat2 As Variant)

    Dim varBuf As Variant
    varBuf = Dat1
    Dat1 = Dat2
    Dat2 = varBuf

End Sub

'配列のバブルソート
Public Sub BubbleSort(ByRef aryDat As Variant, _

    Optional ByVal SortAsc As Boolean = True)

    Dim i As Long
    Dim j As Long
    For i = LBound(aryDat) To UBound(aryDat) - 1
        For j = LBound(aryDat) To LBound(aryDat) + UBound(aryDat) - i - 1
            If aryDat(IIf(SortAsc, j, j + 1)) > aryDat(IIf(SortAsc, j + 1, j)) Then
                Call Swap(aryDat(j), aryDat(j + 1))
            End If
        Next j
    Next i

End Sub

＜使用 Excel：Office365、使用 OS：Windows10 ＞

繰り返し変数の i が偶数か奇数かで、３行進めるか、6行進めるかを分岐すればよいのでは？
バブルソートとか何か関係があるんですか？
（確認） 2022/11/25(金) 17:36:08

確認様

コメントありがとうございます。

説明不足で申し訳ありません。

＞ i が偶数か奇数かで、３行進めるか、6行進めるかを分岐

の方法が分からず質問させていただいた次第です。

バブルソートは参考にしたコードのまま残しております。
（ドナセラ） 2022/11/25(金) 22:26:42

現在のセルの結合状態を説明してください。

（確認） 2022/11/25(金) 22:31:54

    If i Mod 2 = 1 Then
        Set r = r.Offset(3).MergeArea
    Else
        Set r = r.Offset(6).MergeArea
    End If
 ということですが、セル結合の状況ではうまくいかないかもしれません。以上。

（確認） 2022/11/25(金) 22:53:12

 以下のように、Offsetを使わず、行番号を直接使えば間違いはない。
 簡単なモデル例にしています。
 参考にしてください。

 Sub test2()
    Dim r As Range, k&, i&
    k = 1

    '最初のセル範囲
    Set r = Cells(k, "A").MergeArea

    For i = 1 To 4
        If i Mod 2 = 1 Then
            k = k + 3
        Else
            k = k + 6
        End If

        '次のセル範囲
        Set r = Cells(k, "A").MergeArea
    Next
 End Sub
（確認） 2022/11/26(土) 05:19:26

確認様

ご返信ありがとうございます。

分岐方法をご教授いただき、ありがとうございます。

仕事のデータで手元にないため確認が出来ないのですが、
休み明けに動作の確認をしてみます。

行番号の指定も参考にさせていただきます。
取り急ぎお礼まで…
ありがとうございました。
（ドナセラ） 2022/11/26(土) 09:58:50

確認様

教えていただいた分岐方法にて無事解決いたしました。
本当にありがとうございました。
（ドナセラ） 2022/11/28(月) 13:03:25

コメント返信：

[ 一覧(最新更新順) ]

[[20221125170236]] 『画像を交互に2種類の指定行へ貼り付けする』（ドナセラ） ページの最後に飛ぶ

[[20221125170236]]　『画像を交互に2種類の指定行へ貼り付けする』（ドナセラ）　ページの最後に飛ぶ