How to add a loop with a counter in 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

TheGuyThatDoesn'tKnowMuch · Accepted Answer · 2016-04-07 11:47:24Z

4

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.

answered Apr 7, 2016 at 11:47

TheGuyThatDoesn'tKnowMuch

1,2502 gold badges17 silver badges29 bronze badges

Sign up to request clarification or add additional context in comments.

1 Comment

tulanejosh Over a year ago

Wow! That worked really well and it's simple too. Thank you. Tangential question: How do I get from basic counting lastrows and copy/pasting to nested loops? I can understand your code, but find it hard to create something like that without help.

Harley B · Accepted Answer · 2016-04-07 12:09:23Z

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

edited Apr 7, 2016 at 12:09

answered Apr 7, 2016 at 11:54

Harley B

5795 silver badges17 bronze badges

4 Comments

tulanejosh Over a year ago

I used @TheGuyThatDoesn'tKnowMuch response, but this also works. Thank you.

Harley B Over a year ago

Ha! Not quick enough! We came up with almost exactly the same solution though so all good.

Davesexcel Over a year ago

Your cells should be qualified to the correct sheet

Harley B Over a year ago

Well spotted. Edited.

Collectives™ on Stack Overflow

How to add a loop with a counter in vba

2 Answers 2

1 Comment

4 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

1 Comment

4 Comments

Your Answer

Sign up or log in

Post as a guest

Related