クリーナーはコピーと過去のループコードを書きますか？

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）値が必要な場合は、2つの範囲を同じに設定できます。また、私はWithステートメントのファンですが、lastRowとjのためにそれらを一度だけ必要とするので、私は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 

また、4 行を実行する必要はありません。ただを実行し、それが等しい場合、範囲には4つの空でないセルがあることがわかります。