VBA在条件下过滤和复制数据

Question

我有一张纸需要根据某些条件进行过滤，然后将第一列值/和列AT复制到另一张纸上。 第一张（Sheet1）包含多行（但我们只需要利用A和AT列） 因此，如果AT栏包含“N/A”或空白值，则需要将列A和AT值复制到Sheet2中。 我编写VBA代码如下，并停留在过滤中YDest床单，我需要过滤数据并投入另一片上Ydest

“缺少信息”

Private Sub Grab_Click() 
    Dim xSource As Workbook 
    Dim yDest As Workbook 
    '## Open both workbooks first: 

    Set xSource = Workbooks.Open("Vendor Dispatch new.xlsx") 
    Set yDest = Workbooks.Open("Vendor DisPatch Standard.xlsm") 

    With xSource.Sheets("Vendor Dispatch new").UsedRange 
     'Now, paste to y worksheet: 
     yDest.Sheets("Vendor Dispatch new").Range("A2").Resize(_ 
      .Rows.Count, .Columns.Count) = .Value 
     yDest.Sheets("Vendor Dispatch new").Range("A2").WrapText = True 
    End With 
    yDest.Sheets("Vendor Dispatch new").Rows("2:4").Delete 
    'y.Sheets("Vendor Dispatch new").Range("1:1").EntireRow.Interior.Color = 1280 
    'Filter Data with copy into MissingInfoSheet 
    xSource.Close 
    yDest.Save 
    yDest.Close 
End Sub 

Answer 1

试试这个。这是一种使用变体数组的方法。

Sub test() 
    Dim Ws As Worksheet, toWs As Worksheet 
    Dim vDB, vR() 
    Dim xSource As Workbook 
    Dim yDest As Workbook 
    Dim i As Long, n As Long, c As Integer, j As Integer 
    '## Open both workbooks first: 

    Set xSource = Workbooks.Open("Vendor Dispatch new.xlsx") 
    Set yDest = Workbooks.Open("Vendor DisPatch Standard.xlsm") 

    Set Ws = xSource.Sheets("Vendor Dispatch new") 
    Set toWs = yDest.Sheets("Vendor Dispatch new") 

    With Ws 
     r = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 
     c = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column 
     vDB = .Range("a1", .Cells(r, c)) 
     For i = 1 To r 
      If IsError(vDB(i, 46)) Then 
       n = n + 1 
       ReDim Preserve vR(1 To c, 1 To n) 
       For j = 1 To c 
        vR(j, n) = vDB(i, j) 
       Next j 
      Else 
       If vDB(i, 46) = "" Then 
        n = n + 1 
        ReDim Preserve vR(1 To c, 1 To n) 
        For j = 1 To c 
         vR(j, n) = vDB(i, j) 
        Next j 
       End If 
      End If 
     Next i 
    End With 
    With toWs 
     .Cells.Clear 
     .Range("a2").Resize(n, c) = WorksheetFunction.Transpose(vR) 
    End With 
    xSource.Close 
    yDest.Save 
    yDest.Close 
End Sub