マクロ - 別の列にあるすべてのセルの1行を複数回コピーして貼り付けます

Question

2番目の行から開始して、別の列のすべてのセルに対して1行をコピーして貼り付けることができます。

生データは、私が迷子のはここで私はそれがこの

ActiveWorkbook.Names.Add Name:="data1", RefersToR1C1:="=Sheet2!R2C5:R2C7" 
ActiveWorkbook.Names("data1").Comment = "" Range("data1").Copy 
Range("B1").Select ActiveCell.Offset(1, 0).Select ActiveCell.PasteSpecial 

のように見える必要があり、この

のように見えます。私はそれをループさせて、それをそのままにして列を下にしてから、定義した範囲をもう一度コピーする方法はわかりません。

また、私はこれを試してみました：ここ

Dim LastRow As Variant 
    Dim LastRowA As Variant 
    Dim Row As Range 
    Dim i As Integer 

    With Sheets("Store_Item_copy") 
     LastRow = .Range("A2" & Row.Count).End(xlUp).Row 
    End With 

    Range("A2" & LastRow).Copy 

    For i = 2 To LastRow 

     i = i + 1 

     With Sheets("Store_Item_copy") 
      LastRowA = .Range("A" & .Rows.Count).End(xlUp).Row 
     End With 

     LastRowA.Offset(1, 0).Select 
     ActiveCell.PasteSpecial 

    Next i 

Answer 1

は、配列を使用してそれを行うための一つの方法です。

Option Explicit 

Public Sub PopulateColumns() 

    Dim wb As Workbook 
    Dim wsSource As Worksheet 

    Set wb = ThisWorkbook 
    Set wsSource = wb.Worksheets("Sheet1")  'Change as appropriate 

    Dim yearArr() 

    yearArr = wsSource.Range("E2:F" & wsSource.Cells(wsSource.Rows.Count, "E").End(xlUp).Row).Value 

    Dim storesArr() 

    storesArr = wsSource.Range("A2:C" & wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row).Value 

    Dim resultArr() 
    ReDim resultArr(1 To UBound(storesArr, 1) * UBound(yearArr, 1), 1 To 3) 

    Dim counter As Long 
    Dim counter2 As Long 
    Dim x As Long, y As Long 

    For x = 1 To UBound(yearArr, 1) 

     counter2 = counter2 + 1 

     For y = 1 To UBound(storesArr, 1) 

      counter = counter + 1 

      resultArr(counter, 1) = storesArr(y, 1) 
      resultArr(counter, 2) = yearArr(counter2, 1) 
      resultArr(counter, 3) = yearArr(counter2, 2) 

     Next y 

    Next x 

    wsSource.Range("A2").Resize(UBound(resultArr, 1), UBound(resultArr, 2)).Value = resultArr 

End Sub