How to add a loop with a counter in vba - vba

Question

I have a column of IDs in an Excel worksheet called Sheet1. I have data that corresponds to the IDs in columns to the right of Column A. The amount of cells in a row varies. For example:
A, B, C, D, E, F, ...
John, 5, 10, 15, 20
Jacob, 2, 3
Jingleheimmer, 5, 10, 11
I'm trying to copy that data into a new worksheet, Sheet5, in the following format:
A, B, C, D, E, F, ...
John, 5
John, 10
John, 15
John, 20
Jacob, 2
Jacob, 3
Jingleheimmer, 5
Jingleheimmer, 10
Jingleheimmer, 11
I wrote the following code that copies over the first two IDs. I could continue to copy paste the second half of the code and just change the cells, however, I have 100s of IDs. This would take too long. I think whenever a process is repeated I should be using a loop. Can you help me turn this repetitive code into a loop?
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

Try this:
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
It runs through each row in the sheet one at a time, copying over the names and associated numbers up through the last column with values in that row. Should work very quickly and doesn't require constant copy & pasting.

Answer 2

This should do what you're looking for.
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