Highlight Postcodes in XML Files

[Chris Waller]

Hi All,

I have a small excel problem that I need a little help with.

I have a Spreadsheet that contains part of a postcode in column A to be exact the data is between A3 and A63 although there is potential for this to expand. The column contains either the first part of the postcode OL7, M43, or the first part and the first digit of the second part of the postcode WN2 5.

What I am trying to do is to highlight on a couple of XML files any postcode that appears on the Excel Spreadsheet however, the data on the XML files is in a slightly different format. For example the format is as follows
OL7,
M43,
WN2/5.

As I am unsure of the name formats of the files, if it helps I could put the three files in the same directory.

Any help would be greatly appreciated. TIA

 

[pbornemeier]

I did not realize that the codes to be searched for could be a subset of 'the first part of the postcode' so I did not consider that N2 should match WN2. I have remedied this, but in doing so you should realize that unintended matches may occur. If N2 appears any where in the searched text the cell that contains it will be highlighted: N2, WN2, N2W, etc. If a single letter was one of the search terms then all cell containing it would be highlighted. This may not be a problem, I am not familiar with the restrictions in the postal code construction. Let me know if this code works as desired.

Option Explicit

Sub FindPostalCodes()

    'Examine each visible workbook open in this instance of Excel (except for the one containing
    '  this code) for the postal codes listed starting in A3 and down (no blank cells) of the
    '  'Codes' worksheet in this workbook.  When a match is found tint the cells containing one
    '  or more codes yellow.  Color the code characters red and underline them.  I am not sure if
    '  Excel will preserve the coloring when the wprkbook is saved.
    
    'Note:  This code resets the cell color, font color when it is run.  If the imported data
    '  has text with those characteristics, those characteristics will be removed.
    
    'If you have multiple instances of the same postal code in the same cell then the second and
    '  subsequent codes will not be marked.  This can be remedied with additional code.
    
    Dim arySearchData() As Variant
    Dim lSearchIndex As Long
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim sCode As String
    Dim sNewCode As String
    Dim lCodePos As Long
    Dim lPos As Long
    Dim oFound As Object
    Dim lLen As Long
    Dim lCodeLen As Long
    Dim lStart As Long
    Dim sFirstAddr As String
    Dim aryUL As Variant
    
    'Copy postal codes to an array
    ThisWorkbook.Activate
    With Worksheets("Codes")
        ReDim Preserve arySearchData(1 To .Cells(.Rows.Count, 1).End(xlUp).Row - 2)
        For lSearchIndex = 3 To .Cells(.Rows.Count, 1).End(xlUp).Row
            arySearchData(lSearchIndex - 2) = Trim(.Cells(lSearchIndex, 1).Value)
        Next
    End With
    
    'If any codes contain a space, add a value to the array that replaces a space with a slash
    For lSearchIndex = LBound(arySearchData) To UBound(arySearchData)
        sCode = arySearchData(lSearchIndex)
        If InStr(sCode, " ") > 0 Then
            sCode = Replace(sCode, " ", "/")
            ReDim Preserve arySearchData(LBound(arySearchData) To UBound(arySearchData) + 1)
            arySearchData(UBound(arySearchData)) = sCode
        End If
    Next

    For Each wbk In Application.Workbooks
        If wbk.Name <> ThisWorkbook.Name And wbk.Windows(1).Visible = True Then
            For Each wks In wbk.Worksheets
                With wks.UsedRange
                    .Cells.Interior.Color = -4142
                    .Cells.Font.Underline = xlUnderlineStyleNone
                    .Cells.Font.Color = 1
                    For lSearchIndex = LBound(arySearchData) To UBound(arySearchData)
                        sCode = arySearchData(lSearchIndex)
                        lCodeLen = Len(sCode)
                    
                        Set oFound = .Find(What:=sCode, LookIn:=xlFormulas, _
                            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                            MatchCase:=False, SearchFormat:=False)
                        If Not oFound Is Nothing Then
                            sFirstAddr = oFound.Address
                            Do
                                oFound.Interior.Color = 65535
                                
                                'This block is used to change font of the entire cell
                                With oFound.Font
                                    .Underline = xlUnderlineStyleSingle
                                    .Color = 255
                                End With
                                
                                'This block is used to change font of only matching characters
'                                lCodePos = InStr(oFound, sCode)
'                                ReDim aryUL(1 To Len(oFound))
'                                For lPos = 1 To Len(oFound)
'                                    If oFound.Characters(lPos, 1).Font.Underline = xlUnderlineStyleSingle Then
'                                        aryUL(lPos) = 1
'                                    End If
'                                    If lPos >= lCodePos And lPos < lCodePos + lCodeLen Then
'                                        aryUL(lPos) = 1
'                                    End If
'                                    If aryUL(lPos) = 1 Then
'                                        With oFound.Characters(Start:=lPos, Length:=1).Font
'                                            .Color = 255
'                                            .Underline = xlUnderlineStyleSingle
'                                        End With
'                                    End If
'                                Next

                                Set oFound = .FindNext(oFound)
                            Loop While Not oFound Is Nothing And oFound.Address <> sFirstAddr
                        
                        End If
                    Next lSearchIndex
                End With
            Next wks
        End If 'wbk.name
    Next wbk
End Sub