[[20220120121438]] 『繰り返し貼付けマクロについて』(ささみ) >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

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

シート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

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

(もこな2 ) 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

(もこな2) 2022/01/21(金) 01:34


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.