如何在vba中添加一个循环与计数器
我在Excel工作表中有一列名为Sheet1的ID。 我有与A列右侧列中的ID相对应的数据。行中单元格的数量会有所不同。 例如：
A，B，C，D，E，F，…
约翰五，十，十五，二十
雅各布，2，3
Jingleheimmer，5,10,11
我试图将这些数据复制到一个新的工作表Sheet5中，格式如下：
A，B，C，D，E，F，…
约翰，5
约翰，10
约翰15
约翰20
雅各布，2
雅各布，3
Jingleheimmer，5
Jingleheimmer，10
Jingleheimmer，11
我写了下面的代码复制了前两个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 尝试这个：
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
它一次一页地运行在表单中的每一行上，通过最后一列的名称和相关数字复制该行中的值。 应该工作得很快，不需要不断的复制和粘贴。
这应该做你正在寻找的东西。
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