[[20220120121438]]　『繰り返し貼付けマクロについて』（ささみ）　ページの最後に飛ぶ

『繰り返し貼付けマクロについて』（ささみ）

シート1
　　A
1　いちご
2　バナナ
3　ぶどう

シート2
　　A
1　コード1
2　コード2
3　コード3

上記データを使用し

シート3
　　A　　　　B
1　いちご　コード1
2　いちご　コード2
3　いちご　コード3
4　バナナ　コード1
5　バナナ　コード2
6　バナナ　コード3
7　ぶどう　コード1
8　ぶどう　コード2
9　ぶどう　コード3

を作成するマクロを教えて頂けますか。

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

こんなことでしょうか。

 Sub Test()
    Set ws1 = Worksheets("シート1")
    Set ws2 = Worksheets("シート2")
    Set ws3 = Worksheets("シート3")

    n = WorksheetFunction.CountA(ws1.Columns("A")) * WorksheetFunction.CountA(ws2.Columns("A"))
    With ws3
        .Columns("A:B").ClearContents
        .Range("A1").Resize(n).Formula = "=INDEX(" & ws1.Name & "!A:A,INT((ROW(A1)-1)/COUNTA(" & ws2.Name & "!A:A))+1)"
        .Range("B1").Resize(n).Formula = "=INDEX(" & ws1.Name & "!B:B,MOD((ROW(A1)-1),COUNTA(" & ws2.Name & "!A:A))+1)"
    End With
 End Sub

（ひまつぶし） 2022/01/20(木) 12:51

 参考に
 Sub Test()
    Dim i As Long, j As Long, k As Long

    For i = 1 To Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
        For j = 1 To Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
            k = k + 1
            Sheets("Sheet3").Cells(k, "A").Value = Sheets("Sheet1").Cells(i, "A").Value
            Sheets("Sheet3").Cells(k, "B").Value = Sheets("Sheet2").Cells(j, "A").Value
        Next j
    Next i
 End Sub

（ピンク） 2022/01/20(木) 13:00

ひまつぶし様、ピンク様

出来ました！
大変助かりました。
ありがとうございましたm(_ _)m
（ささみ） 2022/01/20(木) 13:21

既に解決済みのようですが参考に。

    Sub 別案()
        Dim RNG1 As Range, RNG2 As Range

        Set RNG1 = Worksheets("シート1").Range("A1").CurrentRegion
        Set RNG2 = Worksheets("シート2").Range("A1").CurrentRegion

        With Worksheets("シート3")
            RNG1.Copy .Range("A1").Resize(RNG1.Rows.Count * RNG2.Rows.Count)

            If RNG1.Rows.Count > 1 Then
                .Sort.SortFields.Clear
                .Sort.SortFields.Add Key:=.Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=Join(WorksheetFunction.Transpose(RNG1.Value), ",")
                .Sort.SetRange .Range("A1").Resize(RNG1.Rows.Count * RNG2.Rows.Count)
                .Sort.Apply
            End If

            RNG2.Copy .Range("B1").Resize(RNG1.Rows.Count * RNG2.Rows.Count)
        End With
    End Sub

ちょっと複雑になっちゃうかもしれませんが、ループ処理や数式を使わなくても解決はできるっぽいです。

（もこな２） 2022/01/20(木) 19:12

暇つぶしに一重ループでもう一案思いついたので投稿しておきます。

    Sub 案2()
        Dim RNG1 As Range, RNG2 As Range, 行 As Long

        Set RNG1 = Worksheets("シート1").Range("A1").CurrentRegion
        Set RNG2 = Worksheets("シート2").Range("A1").CurrentRegion

        For 行 = 1 To RNG1.Rows.Count * RNG2.Rows.Count Step RNG2.Rows.Count
            RNG1.Cells(行 \ RNG2.Rows.Count + 1).Copy Worksheets("シート3").Cells(行, "A").Resize(RNG2.Rows.Count)
            RNG2.Copy Worksheets("シート3").Cells(行, "B")
        Next 行
    End Sub

（もこな２） 2022/01/21(金) 01:34

コメント返信：

[ 一覧(最新更新順) ]

[[20220120121438]] 『繰り返し貼付けマクロについて』（ささみ） ページの最後に飛ぶ

[[20220120121438]]　『繰り返し貼付けマクロについて』（ささみ）　ページの最後に飛ぶ