Question

我有一个Excel VBA代码，它在循环遍历范围时根据一组条件从一行复制特定单元格。下面的代码只是找到，我想知道是否有更清洁的方法来构建它？

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）如果只需要值，可以设置两个相等的范围。此外，我也是[.data.frame语句的粉丝，但由于您只需要With和lastRow一次，我只需将表单放在范围引用之前即可保存四个线。

此外，无需执行4 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行。只需做一个If Not IsEmpty()，如果等于，那么你知道该范围有4个非空单元格。

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

1 个答案: