Filter and Replace Loop

[dutchmenqb]

I have one sheet with a Vendor column that has non-exact matches. (e.g. Walmart #6511 vs. Walmart #1654). I want to make all of those nonexact matches the same (Turn the example values into just Walmart.) I was not able to find a way to directly remove the non-exact matches. This led me to writing code to filter by the beginning of the cell's value (enter in Walmart) and then code to replace all visible cells with Walmart. However, I have 45,000 lines of data, and I do not want to go through each and every one.

In a separate sheet, I have a list of all of the vendor names with duplicates removed. I am hoping to have my code for filtering loop through the list of vendors rather than entering each and every value individually. I'm hoping to loop the code below through my vendor list:

Sub FilterReplace()


Application.DisplayAlerts = False
Dim filtervendor As String
filtervendor = InputBox("Enter Vendor to filter by")
Range("AP1").Value = filtervendor
Range("A2:A45379").AutoFilter Field:=1, Criteria1:=Range("AP1") & "*"
Dim newname As String
newname = InputBox("Enter the new vendor name")
Range("AQ1").Value = newname
Range("A2:A45379").SpecialCells(xlCellTypeVisible).Value = newname
Range("A1").Select


ActiveWorkbook.SaveAs Filename:="C:\Users\jagross\Documents\Project CCS\Credit Card Spend.xlsm"


Application.DisplayAlerts = True


End Sub

Thank you for any and all help

 

[Domenic]

This macro assumes the following...

1) Sheet2, starting at A2, contains the list of vendors.

2) The sheet containing the data is the active sheet.

3) Column A, contains the data.

4) Cell A1 contains the column header/label, and the data starts at A2.

[COLOR=darkblue]Option[/COLOR] [COLOR=darkblue]Explicit[/COLOR]

[COLOR=darkblue]Sub[/COLOR] FilterReplace()

    [COLOR=darkblue]Dim[/COLOR] rVendorList [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] rCell [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] rFilter [COLOR=darkblue]As[/COLOR] Range

    [COLOR=darkblue]With[/COLOR] Application
        .DisplayAlerts = [COLOR=darkblue]False[/COLOR]
        .ScreenUpdating = [COLOR=darkblue]False[/COLOR]
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    
    [COLOR=darkblue]With[/COLOR] Worksheets("Sheet2")
        [COLOR=darkblue]Set[/COLOR] rVendorList = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    
    [COLOR=darkblue]With[/COLOR] ActiveSheet
        [COLOR=darkblue]If[/COLOR] .FilterMode [COLOR=darkblue]Then[/COLOR] .ShowAllData
    End [COLOR=darkblue]With[/COLOR]
    
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]Resume[/COLOR] [COLOR=darkblue]Next[/COLOR]
    [COLOR=darkblue]With[/COLOR] Range("A1", Cells(Rows.Count, "A").[COLOR=darkblue]End[/COLOR](xlUp))
        [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] rCell [COLOR=darkblue]In[/COLOR] rVendorList
            .AutoFilter field:=1, Criteria1:=rCell.Value & "*"
            [COLOR=darkblue]Set[/COLOR] rFilter = .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
            [COLOR=darkblue]If[/COLOR] Err = 0 [COLOR=darkblue]Then[/COLOR]
                rFilter.Value = rCell
            [COLOR=darkblue]Else[/COLOR]
                Err.Clear
            [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
        [COLOR=darkblue]Next[/COLOR] rCell
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] 0
    
    ActiveSheet.AutoFilterMode = [COLOR=darkblue]False[/COLOR]
    
    ActiveWorkbook.SaveAs Filename:="C:\Users\jagross\Documents\Project CCS\Credit Card Spend.xlsm"
    
    [COLOR=darkblue]With[/COLOR] Application
        .DisplayAlerts = [COLOR=darkblue]True[/COLOR]
        .ScreenUpdating = [COLOR=darkblue]True[/COLOR]
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    
    [COLOR=darkblue]Set[/COLOR] rVendorList = [COLOR=darkblue]Nothing[/COLOR]
    [COLOR=darkblue]Set[/COLOR] rCell = [COLOR=darkblue]Nothing[/COLOR]
    [COLOR=darkblue]Set[/COLOR] rFilter = [COLOR=darkblue]Nothing[/COLOR]

End [COLOR=darkblue]Sub[/COLOR]

Hope this helps!