VBA - Filtering via List from Column

[GooberMcGee]

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