用于填充表格的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