宏 - 多次复制并粘贴另一列中每个单元格的单行

Question

我需要帮助从第二行开始多次为另一列中的每个单元格复制和粘贴一行。

原始数据看起来像这样

我需要它看起来像这样

 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