VBA Remove Text String in List based on Criteria in another List

[xcellrodeo]

Hello Mr Excel Community, I would like to ask for help with finding a suitable VBA Script to achieve the following:

Description of Problem:
In Tab called 'Addresses', I have a list of Addresses in Column A (2000 Rows) which take the format of something like this: 'Flat 1 Main Street Brooks London'.
This address string, namely the flat nr, street name, district name and town are all contained in one cell and have only a space as separator.
In Tab called 'Districts', I have a list of 70 District names in Column A (70 Rows).

Result: What I would like to do is to delete all the Districts in the text strings in 'Addresses' sheet in Col. A which are based on the List found in the 'Districts' tab.
So for example, if in Tab 'Addresses', a text string says 'Flat 1 Main Street Brooks London', and the District 'Brooks' is found in the 'Districts' tab, I want it removed from the text string in the Tab 'Addresses'.
Hope this makes sense.

Thanks for any suggestions.
++Please note that above address is a fictitious address and not part of list++

 

[Mentor82]

Hi,
Try this out and let me know if that's what you need. I set up both district and addresses header row as 1. If the header rows are different adjust the constant values accordingly (Distr_HeaderRow, Addr_HeaderRow).

Sub AddressesRemoval()
    Dim wsDistricts As Worksheet
    Dim wsAddresses As Worksheet
    Dim i&
    Dim j&
    Dim lrDistr&
    Dim lrAddresses&
    Dim strDistrict$
    Dim strCurrentAddress$
    Dim strNewAddress$
    
    Const Distr_HeaderRow% = 1
    Const Addr_HeaderRow% = 1
    Const Distr_DefCol$ = "A"
    Const Addr_DefCOl$ = "A"
    
    Set wsDistricts = Worksheets("Districts")
    Set wsAddresses = Worksheets("Addresses")
    
    lrAddresses = wsAddresses.Range(Addr_DefCOl & Cells.Rows.Count).End(xlUp).Row
    lrDistr = wsDistricts.Range(Distr_DefCol & Cells.Rows.Count).End(xlUp).Row
    
    If lrAddresses <= Addr_HeaderRow Or lrDistr <= Distr_HeaderRow Then
        MsgBox "Lack of data to remove districts form addresses!", vbExclamation, "InfoLog"
        Exit Sub
    End If
    
    For i = Distr_HeaderRow + 1 To lrDistr
        lrAddresses = wsAddresses.Range(Addr_DefCOl & Cells.Rows.Count).End(xlUp).Row
        strDistrict = CStr(wsDistricts.Cells(i, Distr_DefCol))
        
        For j = Addr_HeaderRow + 1 To lrAddresses
            strNewAddress = vbNullString
            strCurrentAddress = CStr(wsAddresses.Cells(j, Addr_DefCOl))
            strNewAddress = Replace(strCurrentAddress, strDistrict, "", 1)
            
            strNewAddress = Replace(strNewAddress, LCase(strDistrict), "", 1)
            strNewAddress = Replace(strNewAddress, UCase(strDistrict), "", 1)
            wsAddresses.Cells(j, Addr_DefCOl) = strNewAddress
        Next j
    Next i
    
    Set wsDistricts = Nothing
    Set wsAddresses = Nothing
    
    MsgBox "Done"
    
End Sub

 

[xcellrodeo]

Thanks Sebastian for this.
Can you tell me if the above will work irrespective of case sensitivity so for example if the district is listed in lower or upper case letters or has a mix?