VBA - Filtering via List from Column

Good Day,

I've been by my computer with a VBA/Excel Workbook for the past three hours and cannot figure out why It is not filtering correctly.
I have a list of Card Numbers that I want to filter out. If it's not on the list then move it to a different sheet. If it's on the list then I want to keep it on the sheet.

It seems I am having trouble with the "Diesel" portion of the filtering process. Reefer seems to be working just fine.


It will filter out most of the criteria but not all of it.

Important:
Card Numbers that I want to filter out are in Cells B2:B100
A3:A are the card numbers from the report that need to be processed

Here is what I have so far.

Sub AdjustReport()

Application.ScreenUpdating = False

Dim LookupRng As Range
Dim rng As Range

ThisWorkbook.Activate
Set LookupRng = Worksheets("Card List").Range("B2:B100")

Set FD = Application.FileDialog(msoFileDialogOpen)
With FD
    .AllowMultiSelect = False
    .Title = "Please Select The Fuel Report"
    .Filters.Clear
    .Filters.Add "Excel Files", "*.xl*"
    If .Show = True Then
        FName = .SelectedItems(1)
        Else: MsgBox ("Selected Nothing... You will get nothing...")
        End
    End If
End With

Set vfile = Application.Workbooks.Open(FName)
vfile.Activate

'---------------------------------------------------------------------------------
'---------------------------------------------------------------------------------


Sheets("Diesel").Activate
Set DieselRng = Range("A3", "A" & Range("A3").End(xlDown).Row)

Sheets("Reefer").Activate
Set ReeferRng = Range("A3", "A" & Range("A3").End(xlDown).Row)

Sheets("DEF").Activate
Set DEFRng = Range("A3", "A" & Range("A3").End(xlDown).Row)



Set FaF = Worksheets.Add
FaF.Move After:=Sheets(4)
FaF.Name = "Outside Partners"
Sheets("Diesel").Range("A1:O2").Copy
FaF.Range("A1").PasteSpecial xlPasteAll

'--------------------------------------------------------------------------------------------
'---- The above will select the report, create a new Sheet, and filter out card numbers -----
'--------------------------------------------------------------------------------------------


Set ws = Sheets("Diesel")
ws.Activate
Cnt = DieselRng.Count
i = 1
Do While i <= Cnt
'For i = 1 To Cnt
    Set c = LookupRng.Find(Cells(i + 2, 4))
    If c Is Nothing Or Cells(i + 2, 5) = "" Then
        Cells(i + 2, 1).EntireRow.Cut
        FaF.Activate
        Range("A1000").End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
        ws.Activate
        Cells(i + 2, 1).EntireRow.Select
        Selection.Delete shift:=xlUp
        Cnt = Cnt - 1
        i = i - 1
    End If
    i = i + 1
'Next
Loop

Range("B10000").End(xlUp).FormulaR1C1 = "=COUNTA(R[" & -Cnt - 1 & "]C:R[-2]C)"
Range("I10000").End(xlUp).FormulaR1C1 = "=SUM(R[" & -Cnt - 1 & "]C:R[-2]C)"
Range("M10000").End(xlUp).FormulaR1C1 = "=SUM(R[" & -Cnt - 1 & "]C:R[-2]C)"
Range("N10000").End(xlUp).FormulaR1C1 = "=SUM(R[" & -Cnt - 1 & "]C:R[-2]C)"
Range("O10000").End(xlUp).FormulaR1C1 = "=SUM(R[" & -Cnt - 1 & "]C:R[-2]C)"

'----------------------------------------------------------------------------------------------------------------
'---- The above will filter out card numbers for this sheet and move the ones not listed to Outside Partners-----
'----------------------------------------------------------------------------------------------------------------

Set ws = Sheets("Reefer")
ws.Activate
Cnt = ReeferRng.Count
i = 1
Do While i <= Cnt
    If Cells(i + 2, 5) = "" Then
        Cells(i + 2, 1).EntireRow.Cut
        FaF.Activate
        Range("A1000").End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
        ws.Activate
        Cells(i + 2, 1).EntireRow.Select
        Selection.Delete shift:=xlUp
        Cnt = Cnt - 1
        i = i - 1
    End If
    i = i + 1
'Next
Loop

Range("B10000").End(xlUp).FormulaR1C1 = "=COUNTA(R[" & -Cnt - 1 & "]C:R[-2]C)"
Range("I10000").End(xlUp).FormulaR1C1 = "=SUM(R[" & -Cnt - 1 & "]C:R[-2]C)"
Range("M10000").End(xlUp).FormulaR1C1 = "=SUM(R[" & -Cnt - 1 & "]C:R[-2]C)"
Range("N10000").End(xlUp).FormulaR1C1 = "=SUM(R[" & -Cnt - 1 & "]C:R[-2]C)"
Range("O10000").End(xlUp).FormulaR1C1 = "=SUM(R[" & -Cnt - 1 & "]C:R[-2]C)"
'----------------------------------------------------------------------------------------------------------------
'---- The above will filter out card numbers for this sheet and move the ones not listed to Outside Partners-----
'----------------------------------------------------------------------------------------------------------------
Set ws = Sheets("DEF")
ws.Activate
Cnt = DEFRng.Count
i = 1
Do While i <= Cnt
    Set c = LookupRng.Find(Cells(i + 2, 4), LookIn:=xlValues)
    If c Is Nothing Or Cells(i + 2, 5) = "" Then
        Cells(i + 2, 1).EntireRow.Cut
        FaF.Activate
        Range("A1000").End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
        ws.Activate
        Cells(i + 2, 1).EntireRow.Select
        Selection.Delete shift:=xlUp
        Cnt = Cnt - 1
        i = i - 1
    End If
    i = i + 1
Loop

Range("B10000").End(xlUp).FormulaR1C1 = "=COUNTA(R[" & -Cnt - 1 & "]C:R[-2]C)"
Range("I10000").End(xlUp).FormulaR1C1 = "=SUM(R[" & -Cnt - 1 & "]C:R[-2]C)"
Range("M10000").End(xlUp).FormulaR1C1 = "=SUM(R[" & -Cnt - 1 & "]C:R[-2]C)"
Range("N10000").End(xlUp).FormulaR1C1 = "=SUM(R[" & -Cnt - 1 & "]C:R[-2]C)"
Range("O10000").End(xlUp).FormulaR1C1 = "=SUM(R[" & -Cnt - 1 & "]C:R[-2]C)"
'----------------------------------------------------------------------------------------------------------------
'---- The above will filter out card numbers for this sheet and move the ones not listed to Outside Partners-----
'----------------------------------------------------------------------------------------------------------------
FaF.Activate
Cnt = Range("A10000").End(xlUp).Row - 2

Range("A10000").End(xlUp).Offset(2, 0) = "Count"
Range("B10000").End(xlUp).Offset(2, 0).FormulaR1C1 = "=COUNTA(R[" & -Cnt - 1 & "]C:R[-2]C)"
Range("I10000").End(xlUp).Offset(2, 0).FormulaR1C1 = "=SUM(R[" & -Cnt - 1 & "]C:R[-2]C)"
Range("M10000").End(xlUp).Offset(2, 0).FormulaR1C1 = "=SUM(R[" & -Cnt - 1 & "]C:R[-2]C)"
Range("N10000").End(xlUp).Offset(2, 0).FormulaR1C1 = "=SUM(R[" & -Cnt - 1 & "]C:R[-2]C)"
Range("O10000").End(xlUp).Offset(2, 0).FormulaR1C1 = "=SUM(R[" & -Cnt - 1 & "]C:R[-2]C)"
'--------------------------------------------------------------------
'---- The above will select outside partners and keep it active -----
'--------------------------------------------------------------------


Application.ScreenUpdating = True

End Sub

Originally Posted by GooberMcGee

It will filter out most of the criteria but not all of it.

When I see a comment like that, the issue often has to do with both the code and the nature of your data. We probably can't help you without an example workbook with data that illustrates the problem.


Attach a sample workbook (not a picture or pasted copy). Make sure there is just enough data to demonstrate your need. Include a BEFORE sheet and an AFTER sheet in the workbook if needed to show the process you're trying to complete or automate. Make sure your desired results are shown, mock them up manually if necessary.

Remember to desensitize the data.

Click on GO ADVANCED and then scroll down to Manage Attachments to open the upload window.

Heya,
I still need help with this;

I am trying to use "Filtering Sheet" to select "Unfiltered" and go through Column A on each sheet of "Unfiltered" and if numbers match Column A on the "Filtering Sheet" then keep them there, if not move the row that has the unmatched number to a new sheet then make it nice and neat then save the workbook as a new workbook.

Thanks

Sub AdjustReport()
    
    Dim LookupRng As Range
    Dim rng       As Range
    Dim FName     As String
    Dim vfile     As Workbook
    Dim FaF       As Worksheet
    Dim ws        As Worksheet
    
    Application.ScreenUpdating = False
    
    With ThisWorkbook.Worksheets("Card List")
        Set LookupRng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
    End With
    
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = False
        .Title = "Please Select The Fuel Report"
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xl*"
        If .Show = True Then
            FName = .SelectedItems(1)
        Else: MsgBox ("Selected Nothing... You will get nothing...")
            Exit Sub
        End If
    End With
    
    Set vfile = Application.Workbooks.Open(FName)
    'vfile.Activate
    
    'Add sheet
    Set FaF = vfile.Worksheets.Add(After:=vfile.Sheets(vfile.Sheets.Count))
    FaF.Name = "Outside Partners"
    
    'Copy headers
    vfile.Sheets("Diesel").Range("A1:O2").Copy
    FaF.Range("A1").PasteSpecial xlPasteColumnWidths
    FaF.Range("A1").PasteSpecial xlPasteAll
    Application.CutCopyMode = False
    FaF.Range("A1").Value = "Outside Partners"
    
    '---------------------------------------------------------------------------------
    'Filter sheets
    '---------------------------------------------------------------------------------
    For Each ws In vfile.Sheets(Array("Diesel", "Reefer", "DEF"))
    
        ws.Range("A" & Rows.Count).End(xlUp).EntireRow.ClearContents
        Set rng = ws.Range("A3", ws.Range("A3").End(xlDown))
    
        For Each cell In rng
            If cell.Value <> "" Then
                If LookupRng.Find(cell.Text, , xlValues, xlWhole, 1, 1, 0) Is Nothing Then
                    cell.EntireRow.Copy Destination:=FaF.Range("A" & Rows.Count).End(xlUp).Offset(1)
                    cell.EntireRow.ClearContents
                End If
            End If
        Next cell
        
        'Delete en masse the cleared rows
        With ws.Range("A2", ws.Range("A" & Rows.Count).End(xlUp))
            .AutoFilter 1, "="
            .Offset(1).EntireRow.Delete
        End With
        ws.AutoFilterMode = False
        
        With ws.Range("A" & Rows.Count).End(xlUp)
            .Offset(2, 0).Value = "Count"
            .Offset(2, 1).FormulaR1C1 = "=COUNTA(R3C:R[-2]C)"
            .Offset(2, 8).FormulaR1C1 = "=SUM(R3C:R[-2]C)"
            .Offset(2, 12).FormulaR1C1 = "=SUM(R3C:R[-2]C)"
            .Offset(2, 13).FormulaR1C1 = "=SUM(R3C:R[-2]C)"
            .Offset(2, 14).FormulaR1C1 = "=SUM(R3C:R[-2]C)"
        End With
    
    Next ws
    
    '--------------------------------------------------------------------
    '---- Select outside partners and keep it active -----
    '--------------------------------------------------------------------
    FaF.Activate
    With FaF.Range("A" & Rows.Count).End(xlUp)
        .Offset(2, 0).Value = "Count"
        .Offset(2, 1).FormulaR1C1 = "=COUNTA(R3C:R[-2]C)"
        .Offset(2, 8).FormulaR1C1 = "=SUM(R3C:R[-2]C)"
        .Offset(2, 12).FormulaR1C1 = "=SUM(R3C:R[-2]C)"
        .Offset(2, 13).FormulaR1C1 = "=SUM(R3C:R[-2]C)"
        .Offset(2, 14).FormulaR1C1 = "=SUM(R3C:R[-2]C)"
    End With
        
    Application.ScreenUpdating = True
    
End Sub

You're welcome.