VBA需要嵌套循环来移动列

对编码VBA不是很有经验，但是我很感激这个问题。 下面的代码运行良好; 不过从逻辑上讲，我觉得可以写得更好。 任何人有build议？

Sub CopyValues() 'Declare variables Dim Sourcedataws As Worksheet Dim WStotransfer As Worksheet 'Declare counter variables Dim i As Integer Dim lastrow As Long 'Declare sheet variables Set Sourcedataws = ThisWorkbook.Sheets("Source Data") Set WStotransferws = ThisWorkbook.Sheets("WStotransfer") lastrow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row For i = 2 To lastrow If Sourcedataws.Range("AA" & i).Value = "Condition" Then WStotransferws.Range("C18") = Sourcedataws.Range("A" & i).Value ActiveCell.Offset(0, 1).Select WStotransferws.Range("D18") = Sourcedataws.Range("A" & i).Value ActiveCell.Offset(0, 1).Select WStotransferws.Range("E18") = Sourcedataws.Range("A" & i).Value ActiveCell.Offset(0, 1).Select WStotransferws.Range("F18") = Sourcedataws.Range("A" & i).Value ActiveCell.Offset(0, 1).Select WStotransferws.Range("G18") = Sourcedataws.Range("A" & i).Value ActiveCell.Offset(0, 1).Select WStotransferws.Range("H18") = Sourcedataws.Range("A" & i).Value ActiveCell.Offset(0, 1).Select WStotransferws.Range("I18") = Sourcedataws.Range("A" & i).Value End If Next End Sub 

Answer 1

尝试：

 Sub CopyValues() 'Declare counter variables Dim i As Integer, j as Integer, lastrow As Long 'Declare variables Dim Sourcedataws As Worksheet, WStotransfer As Worksheet 'Declare sheet variables Set Sourcedataws = ThisWorkbook.Sheets("Source Data") Set WStotransferws = ThisWorkbook.Sheets("WStotransfer") lastrow = Sourcedataws.Cells(Sourcedataws.Rows.Count, "A").End(xlUp).Row WStotransferws.Range("C18:I18").ClearContents For i = 2 To lastrow If WStotransferws.Range("I18").Value="" Then If Sourcedataws.Range("AA" & i).Value = "Condition" Then Sourcedataws.Range("A"&i).Copy j=WStotransferws.Cells(18, WStotransferws.Columns.Count).End(xlToLeft).Column WStotransferws.Cells(18,j+1).PasteSpecial xlPasteValues End If Else End If Next i End Sub