Sub subAddLocationsV4()
' The Serial Numbers are unique primary keys. In this case, because there's
' a known fixed number of them, I've used an array to store those keys.
Dim aKeys As Variant
aKeys = Sheet2.Range("A2:A8").Value
' The corresponding items are the locations. For each of the Serial Number keys
' store the locations in the same position in another array.
Dim aItems As Variant
aItems = Sheet2.Range("D2:D8").Value
' Declaring "i" as an integer for doing the loops
Dim i As Integer
' Loop through all the Worksheets in the Workbook EXCEPT Sheet2
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Sheet2" Then
ws.Activate
' In case you have leftover formatting in the Replace dialog box from previous
' searches, this clears it
Application.FindFormat.Clear
Application.ReplaceFormat.Clear
' Loop from 1 to the number of (i.e. count of) the aKeys array. This is because
' we need to replace for every Serial Number
For i = 1 To UBound(aKeys)
' Search for the Serial number. Because of the way the array aKeys is created it
' creates a 2D array, with the Serial numbers being in #1 of the second dimension
' e.g. 4THGPL2 is in aKeys(1, 1), 700GPL2 in aKeys (2, 1) and so on. The find text
' is the key, e.g. aKeys(1, 1) / 700GPL2, the replace text is that plus a space
' plus the item fron the Location array, so, e.g. aItems(1, 1) / NGMANB301E80013
' (SJ) RM 211 (DESK 2). You also need to ensure that the whole cell is searched
' because in your example screenshot that is how they appeared.
Cells.Replace What:=aKeys(i, 1), Replacement:=aKeys(i, 1) & " " & aItems(i, 1), _
LookAt:=xlWhole, SearchOrder:=xlByRows
Next
' The next step is to loop through the used range of Sheet 1 and apply the
' formatting. Three variables are used: one for the first address of where the
' Serial Number being looked for appears, one for the address as a string, and
' the third, c, a range (i.e. in this case used for a cell address
Dim fAddress As String, sAddress As String, c As Range
' Loop (as above)
For i = 1 To UBound(aKeys)
' Limits the work to the used range of Sheet1
With ws.UsedRange
' Find the aKeys(i, 1), so for aKeys(1, 1) that's 4THGPL2, in
' any values of the cells in the used range and because those cells
' now have the location data also included within them the search needs
' to be for where it appears in *part* of the cell
Set c = .Find(aKeys(i, 1), LookIn:=xlValues, LookAt:=xlPart)
' If there is a cell with the aKeys(i, 1) then set the first address
' to the address of that cell
If Not c Is Nothing Then
fAddress = c.Address
Do
' Set that address to the string variable sAddress so that
' it can be passed to the "With" that follows
sAddress = c.Address
' Literally activate that found cell because we are now wanting
' to apply formatting to an active cell. Normally you don't need
' to select/activate cells, though I'm unsure whether there's any
' way not to in this case of applying *partial* cell formattng.
Range(sAddress).Activate
' Apply only Bold+Blue, noting that VBA has a constant vbBlue for
' blue, but this could be a number also representing any "blue"
' colour if the 'default' one is not wanted. Apply it only after the
' text where the Serial Number is appearing, so FROM Len(gth) of aKeys(i, 1)
' plus 1 for the space character that was added TO the end (i.e. the
' Len(gth) of the entire range, which is the cell located at sAddress
With ActiveCell.Characters(Len(aKeys(i, 1)) + 1, Len(Range(sAddress).Value)).Font
.FontStyle = "Bold"
.Color = vbBlue
End With
' Now loop to see whether there are any more of that Serial Number
Set c = .FindNext(c)
' And if there are do this again, otherwise we've found all of the Serial Numbers
' in that range.
Loop While Not c.Address = fAddress
End If
End With
' Do the next Serial Number
Next i
End If
Next
End Sub
