更清洁的方式来写复制和过去的循环代码？

我有一个Excel VBA代码，可以根据一组标准循环访问一个范围，从一行中复制特定的单元格。 下面的代码工作只是发现，我想知道是否有一个更清洁的方式来build立它？

Dim sh1 As Worksheet, sh2 As Worksheet Dim LastRow As Long, i As Long, j As Long With ThisWorkbook Set sh2 = .Sheets.Add(After:=.Sheets(.Sheets.Count)) sh2.Name = "Upload" sh2.Range("A1").Value = "Date" sh2.Range("B1").Value = "Ledger Acct" sh2.Range("C1").Value = "Department" sh2.Range("D1").Value = "Cost Center" sh2.Range("E1").Value = "Purpose" sh2.Range("F1").Value = "Account Name" sh2.Range("G1").Value = "Transaction Text" sh2.Range("H1").Value = "Line Amount" sh2.Range("I1").Value = "Currency" End With Set sh1 = Sheets("Remaining for Uploads") 'This will find the last used row in a column A on sh1' With sh1 LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row End With 'First row number where the values will be pasted in Upload' With sh2 j = .Cells(.Rows.Count, "A").End(xlUp).Row End With For i = 2 To LastRow With sh1 If Not (IsEmpty(.Cells(i, 7))) And Not (IsEmpty(.Cells(i, 8))) And Not (IsEmpty(.Cells(i, 9))) And Not (IsEmpty(.Cells(i, 10))) Then .Cells(i, 7).Copy sh2.Range("B" & j).PasteSpecial xlPasteValues .Cells(i, 8).Copy sh2.Range("C" & j).PasteSpecial xlPasteValues .Cells(i, 9).Copy sh2.Range("D" & j).PasteSpecial xlPasteValues .Cells(i, 10).Copy sh2.Range("E" & j).PasteSpecial xlPasteValues .Cells(i, 13).Copy sh2.Range("H" & j).PasteSpecial xlPasteValues j = j + 1 End If End With Next i 

Answer 1

一些事情要收紧代码。 1）您可以使用数组来加载您的标题。 2）如果你只需要这些值，你可以设置两个相等的范围。 另外，我也是一个With语句的粉丝，但是因为你只需要一次lastRow和j ，所以我把表单放在范围引用前面，以节省四行。

 Sub t() Dim sh1 As Worksheet, sh2 As Worksheet Dim LastRow As Long, i As Long, j As Long Dim headers() As Variant headers = Array("Date", "Ledger Acct", "Department", "Cost Center", "Purpose", "Account Name", "Transaction Text", "Line Amount", "Currency") With ThisWorkbook Set sh2 = .Sheets.Add(After:=.Sheets(.Sheets.Count)) sh2.Name = "Upload" For i = LBound(headers) To UBound(headers) sh2.Cells(1, i + 1).Value = headers(i) 'i + 1 because arrays start with 0 index, not 1. Next i End With Set sh1 = Sheets("Remaining for Uploads") 'This will find the last used row in a column A on sh1' LastRow = sh1.Cells(sh1.Rows.Count, "A").End(xlUp).Row 'First row number where the values will be pasted in Upload' j = sh2.Cells(sh2.Rows.Count, "A").End(xlUp).Row Dim copyRng As Range, destRng As Range With sh1 For i = 2 To LastRow Set copyRng = .Range(.Cells(i, 7), .Cells(i, 10)) If WorksheetFunction.CountA(copyRng) = 4 Then ' use COUNTA() to count cells that are not empty Union(sh2.Range(sh2.Cells(j, 2), sh2.Cells(j, 5)), sh2.Cells(j, 8)).Value = Union(copyRng, .Cells(i, 13)).Value End If j = j + 1 Next i End With 'sh1 End Sub 

另外，不需要执行4 If Not IsEmpty()行。 只要做一个COUNTA() ，如果等于，那么你知道该范围有4个非空单元格。