VBA条件でのデータのフィルタリングとコピー

Question

ある条件に基づいてフィルタリングする必要があるシートが1つあり、最初の列の値/および列ATを別のシートにコピーします。 最初のシート（Sheet1）には複数の行が含まれています（ただし、A列とAT列だけを使用する必要があります） AT列に「N/A」または空白の値が含まれている場合に備えて列AとAT値をSheet2。 Ydest

に、私は以下のようにVBAコードを書いて、私はデータをフィルタリングし、別のシートに配置する必要があり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