清潔的方式來寫入副本和過去的循環代碼？

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）如果你只需要這些值，你可以設置兩個相等的範圍。此外，我的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個非空單元格。