Makro- Kopieren und Einfügen einer einzelnen Zeile für jede Zelle in einer anderen Spalte mehrere Male

Question

Ich brauche Hilfe zum Kopieren und Einfügen einer einzelnen Zeile für jede Zelle in einer anderen Spalte mehrere Male beginnend in der zweiten Zeile.

Die Rohdaten wie folgt aussieht

ich es brauche dieses aussehen wie

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 

Hier ist, wo ich verloren gehen. Ich bin mir nicht sicher, wie ich es abwickeln und dann weitermachen und die Spalte a runter und dann den definierten Bereich wieder kopieren soll.

Ich habe auch versucht dies:

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

Hier ist eine Möglichkeit, es mit Arrays zu tun.

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