So fügen Sie eine Schleife mit einem Zähler in Vba

Question

Ich habe eine Spalte von IDs in einem Excel-Arbeitsblatt namens Sheet1. Ich habe Daten, die den IDs in Spalten rechts von Spalte A entsprechen. Die Anzahl der Zellen in einer Zeile variiert. Zum Beispiel:

A, B, C, D, E, F, ...

John, 5, 10, 15, 20

Jacob, 2, 3

Jingleheimmer, 5, 10, 11

ich versuche, Daten in ein neues Arbeitsblatt, Sheet5, in folgendem Format zu kopieren, dass:

A, B, C, D, E, F, ...

John, 5

John, 10

John, 15

John, 20

Jacob, 2

Jacob, 3

Jingleheimmer, 5

Klingeheimmer, 10

Jingleheimmer, 11

Ich schrieb den folgenden Code, die Kopien in den ersten beiden IDs. Ich könnte weiterhin kopieren die zweite Hälfte des Codes einfügen und nur die Zellen ändern, aber ich habe 100 von IDs. Das würde zu lange dauern. Ich denke, wenn ein Prozess wiederholt wird, sollte ich eine Schleife verwenden. Kannst du mir helfen, diesen repetitiven Code in eine Schleife zu verwandeln?

Sub Macro5() 

Dim LastRowA As Integer 
Dim LastRowB As Integer 

''' Process of copying over first ID ''' 

'grab all data cells in B2 to the right 
With Sheets("Sheet1").Select 
Range("B2", Range("B2").End(xlToRight)).Select 
Selection.Copy 
End With 

'paste that data into the first empty cell of Column B in Sheet5 
With Sheets("Sheet5").Select 
Range("B1").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
End With 

'grab the corresponding ID in cell A2 
With Sheets("Sheet1").Select 
Range("A2").Select 
Application.CutCopyMode = False 
Selection.Copy 
End With 

'paste the corresponding ID into the first empty cell of Column A in Sheet5 
With Sheets("Sheet5").Select 
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row 
Range("A1").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
     :=False, Transpose:=False 
Application.CutCopyMode = False 
Selection.AutoFill Destination:=Range("A1:A" & LastRowB) 
End With 

''' Repeat that process for each row in Sheet1 ''' 

'grab all data cells in B3 to the right 
With Sheets("Sheet1").Select 
Range("B3", Range("B3").End(xlToRight)).Select 
Selection.Copy 
End With 

'paste that data into the first empty cell of Column B in Sheet5 
With Sheets("Sheet5").Select 
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row 
Range("B" & LastRowB + 1).Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
End With 

'grab the corresponding ID in cell A3 
With Sheets("Sheet1").Select 
Range("A3").Select 
Application.CutCopyMode = False 
Selection.Copy 
End With 

'paste the corresponding ID into the first empty cell of column A in Sheet5 
'and autofill down to the last populated cell in column B 
With Sheets("Sheet5").Select 
LastRowA = Cells(Rows.Count, "A").End(xlUp).Row + 1 
Range("A" & LastRowB + 1).Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
     :=False, Transpose:=False 
Application.CutCopyMode = False 
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row 
Selection.AutoFill Destination:=Range("A" & LastRowA & ":A" & LastRowB) 
End With 

End Sub 

Answer 1

Diese Versuchen:

Sub test() 

Dim i As Integer 
Dim j As Integer 
Dim ws1 As Worksheet 
Dim ws2 As Worksheet 
Dim nRow As Integer 
Dim lRow As Integer 
Dim lCol As Integer 

Set ws1 = Sheets("Sheet1") 
Set ws2 = Sheets("Sheet5") 
nRow = 1 

With ws1 

    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row 

    For i = 1 To lRow 

     lCol = .Cells(i, .Columns.Count).End(xlToLeft).Column 

     For j = 2 To lCol 

      ws2.Cells(nRow, 1).Value = .Cells(i, 1).Value 
      ws2.Cells(nRow, 2).Value = .Cells(i, j).Value 
      nRow = nRow + 1 

     Next j 

    Next i 

End With 

End Sub 

Es läuft durch jede Reihe in dem Bogen eines nach dem anderen, Kopieren über die Namen und die zugehörigen Zahlen nach oben durch die letzte Spalte mit Werten in dieser Zeile. Sollte sehr schnell arbeiten und erfordert keine konstante Kopie & einfügen.

Answer 2

Dies sollte tun, was Sie suchen.

Sub test() 
Dim lastrow As Long, lastcol As Long 
Dim i As Integer, j as Integer, x as Integer 
Dim ws1 As Worksheet 
Dim ws2 As Worksheet 

Set ws1 = Sheets("Sheet1") 
Set ws2 = Sheets("Sheet5") 

lastrow = ws1.Cells(Rows.Count, "A").End(xlUp).Row 
x = 1 

With ws1 
    For i = 1 To lastrow 
     lastcol = .Cells(i, .Columns.Count).End(xlToLeft).Column 
     For j = 2 To lastcol 
      ws2.Cells(x, 1).Value = .Cells(i, 1).Value 
      ws2.Cells(x, 2).Value = .Cells(i, j).Value 
      x = x + 1 
     Next j 
    Next i 
End With 

End Sub