Sub subAddLocationsV3()
' 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.
' A nicer, and in many cases better, way is to use a dictionary, but in this
' use case using two arrays is fine.
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, aItems.
Dim aItems As Variant
aItems = Sheet2.Range("D2:D8").Value
' Declaring "i" as an integer for doing the loops. Incidentally, the Long data
' type is probably the "fastest" to process now but for understanding,
' integer is good and the loop will always be one, so may as well use that
' Another incidental point: I have declared all of the variables - you may see
' this omitted, bit if it is then they will be Variant data types. It's better
' practice to Dim and use precise data types.
Dim i As Integer
' Literally activating Sheet1 because I then do a Search and Replace,
' so we need to be in that Worksheet
Sheet1.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:
' 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 from 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 cell address (e.g. $B$5) 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 (similar to above)
For i = 1 To UBound(aKeys)
' Limits the work to the used range of Sheet1
With Sheet1.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 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 formatting.
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 instances of that Serial Number
' in that range.
Loop While Not c.Address = fAddress
End If
End With
' Do the next Serial Number
Next i
End Sub
