Still learning the ropes so bear with! I have a monthly data dump that will be copied into the workbook, it is always in the same format. I'm trying to write a macro that filters the data in a preset column using a list of names from another sheet within the workbook. Ideally I want to be able to add or remove names from the list. Once it has filtered I'd like it to copy all those visible cells and paste them into a new sheet.

I've started with using the autofilter and then a counting array, but I am getting an error AND it's not filtering. In that the filter is applied to the sheet, but it doesn't seem to be able to look for the actual names, and just returns blanks. It does seem to count the right number of names in my dynamic list... so I'll take that.

So example data: Worksheet: Names

Worksheet: Books

Code ideally takes the list of names from the Person column in "Names", looks through the Name column "Books", finds each match and then copies and dumps the entire row to a new sheet.

Here is my best attempt at writing something.

Sub FilterName()
Dim i As Long
Dim lastrow As Long
Dim arrSummary() As Variant

With ThisWorkbook.Sheets("Names")
  lastrow = .Cells(Rows.Count, "B").End(xlUp).Row
  ReDim arrSummary(1 To lastrow)

  For i = 1 To lastrow
  arrSummary(i) = .Cells(i, 1)
  Next

End With
For i = LBound(arrSummary) To UBound(arrSummary)
      With ThisWorkbook.Sheets("Books")
      .Range("F:F").AutoFilter Field:=1, Criteria1:=arrSummary(i), Operator:=xlFilterValues
      
    .ThisWorkbook.Sheets("Books").Range("A1:AA100000").SpecialCells(xlCellTypeVisible).Copy
    'Getting error 438 here
    .ThisWorkbook.Sheets("Loans").Paste
      End With
Next i

End Sub

I did contemplate advanced filter but couldn't make that work even outside of VBA, and then didn't want to do the find route as felt it was clunky...Willing to explore these options though.

Cheers :)

CodePudding user response：

You can achieve your goal without VBA but with the new FILTER-function if you have Excel 365.

In my example I created two tables (Insert > Table) named them tblPeople and tblBooks.

That way the formula is very easy to read:

Regarding your code: When you have a lot of data this process will be very slow.

In general you achieve a better performance when reading the data into an array (like you already did with the peoples sheet), do the filtering in the array and then write the array back to the sheet (you will find a lot of examples here on SO.

By the way: you can read a range to an array like this: arrSummary = rg.value where rg is the range you want to read.

CodePudding user response：

Filter Names

• It will write the values from column B (cCol) of the criteria worksheet (cws) to a 2D one-based one-column array (cData). Then it will loop through the values in the array and filter the 6th column (scCol) of the source worksheet (sws) by each of the array's values and copy the source range's (A:AA) rows that contain the matching cells to the first available row of the destination worksheet (dws) starting in column A (dfCol).

Option Explicit

Sub FilterNames()
    
    ' Criteria
    Const cName As String = "Names"
    Const cCol As String = "B"
    Const cfRow As Long = 2
    ' Source
    Const sName As String = "Books"
    Const sCols As String = "A:AA"
    Const scCol As Long = 6 ' also used for AutoFilter's Field parameter
    Const sfRow As Long = 1
    ' Destination
    Const dName As String = "Loans"
    Const dfCol As String = "A"
    Const dfRow As Long = 2
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Criteria
    Dim cws As Worksheet: Set cws = wb.Worksheets(cName)
    Dim clRow As Long: clRow = cws.Cells(cws.Rows.Count, cCol).End(xlUp).Row
    If clRow < cfRow Then Exit Sub
    Dim crCount As Long: crCount = clRow - cfRow   1
    Dim crg As Range: Set crg = cws.Cells(cfRow, cCol).Resize(crCount)
    Dim cData As Variant
    If crCount = 1 Then
        ReDim cData(1 To 1, 1 To 1): cData(1, 1) = crg.Value
    Else
        cData = crg.Value
    End If
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.UsedRange.Columns(sCols)
    Dim sdrg As Range: Set sdrg = srg.Resize(srg.Rows.Count - 1).Offset(1)
    Dim sdcrg As Range: Set sdcrg = sdrg.Columns(scCol)
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dfCol).End(xlUp).Row
    Dim dCell As Range
    If dlRow < dfRow Then
        Set dCell = dws.Cells(dfRow, dfCol)
    Else
        Set dCell = dws.Cells(dlRow, dfCol).Offset(1)
    End If
    
    Application.ScreenUpdating = False
    
    Dim drCount As Long
    Dim r As Long
    
    For r = 1 To UBound(cData, 1)
        sws.AutoFilterMode = False
        srg.AutoFilter scCol, CStr(cData(r, 1)), xlFilterValues
        drCount = Application.Subtotal(103, sdcrg)
        Debug.Print drCount, cData(r, 1)
        If drCount > 0 Then
            sdrg.SpecialCells(xlCellTypeVisible).Copy
            dCell.PasteSpecial xlPasteValues
            Set dCell = dCell.Offset(drCount)
        End If
    Next r

    Application.CutCopyMode = False
    sws.AutoFilterMode = False
    
    If dws Is ActiveSheet Then
        dws.Range("A1").Activate
    Else
        Dim ash As Worksheet: Set ash = ActiveSheet
        dws.Activate
        dws.Range("A1").Activate
        ash.Activate
    End If
    
    'wb.Save
    
    Application.ScreenUpdating = True
    
    MsgBox "Data transferred.", vbInformation, "Filter Names"
    
End Sub