如何在vba中添加带计数器的循环

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:

我在名为Sheet1的Excel工作表中有一列ID。我的数据对应于A列右侧列中的ID。一行中的单元格数量不尽相同。例如:

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

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

John, 5, 10, 15, 20

约翰,5,10,15,20

Jacob, 2, 3

雅各布,2,3

Jingleheimmer, 5, 10, 11

Jingleheimmer,5,10,11

I'm trying to copy that data into a new worksheet, Sheet5, in the following format:

我正在尝试将这些数据复制到新工作表Sheet5中,格式如下:

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

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?

我编写了以下代码,复制了前两个ID。我可以继续复制粘贴代码的后半部分,只需更改单元格,但是,我有100个ID。这将花费太长时间。我想每当一个过程重复时,我应该使用一个循环。你能帮我把这个重复的代码变成一个循环吗?

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

2 个解决方案

#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.

它一次遍历工作表中的每一行,将最后一列中的名称和关联数字复制到该行中的值。应该非常快速地工作,不需要不断复制和粘贴。

#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

#1