用於填充表格的Excel VB腳本

Question

對於最近的所有問題都抱歉，但我對VB很陌生。在我的腳本中，當我在空白表單上運行它時，它運行得非常完美。但是，當我嘗試運行它來填充具有相同值的表格時，它會在所有值之間留出巨大空間。有什麼我忘記放在劇本本身？

代碼

For Each i In ddg 

     Unit = "Unit #" & i 

     LastRow = Sheets("Test").Range("A50000").End(xlUp).Row + 1 

     Sheets(Unit).Range("A2:A100").Copy Destination:=Sheets("Test").Range("A" & LastRow) 

     Sheets(Unit).Range("B2:B100").Copy Destination:=Sheets("Test").Range("D" & LastRow) 

     Sheets(Unit).Range("C2:C100").Copy Destination:=Sheets("Test").Range("E" & LastRow) 

     Sheets(Unit).Range("D2:D100").Copy Destination:=Sheets("Test").Range("F" & LastRow) 

     Sheets(Unit).Range("E2:E100").Copy Destination:=Sheets("Test").Range("G" & LastRow) 

     Sheets(Unit).Range("F2:F100").Copy Destination:=Sheets("Test").Range("L" & LastRow) 


    Next i 

Answer 1

它看起來像你想一個表中的值複製形式另一片的基礎上，具體的標準。你的代碼看起來很奇怪。你知道你需要完全符合你的工作表，對。像這樣嘗試。

Sub Copy_If_Criteria_Met() 
    Dim xRg As Range 
    Dim xCell As Range 
    Dim I As Long 
    Dim J As Long 
    I = Worksheets("Sheet1").UsedRange.Rows.Count 
    J = Worksheets("Sheet2").UsedRange.Rows.Count 
    If J = 1 Then 
     If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0 
    End If 
    Set xRg = Worksheets("Sheet1").Range("A1:A" & I) 
    On Error Resume Next 
    Application.ScreenUpdating = False 
    For Each xCell In xRg 
     If CStr(xCell.Value) = "X" Then 
      xCell.EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1) 
      xCell.EntireRow.Delete 
      J = J + 1 
     End If 
    Next 
    Application.ScreenUpdating = True 
End Sub