VBA code to take some string components search them inside a workbook and replace the components with the cell addresses found

Question

In an Excel column, I have formulas that return TRUE or FALSE. Each formula consists of alphanumeric strings that always begin with the letter ABC and end with seven digits. The string's center section can change.

For example:

=OR(ABC_XYZ_0001234 >0 , ABC_XYZ_0001235 <0).

These strings of letters and numbers represent cells from another workbook. These strings should be replaced with the cell address where they were located.

For example:

 =OR('[Wrkbook.xlsx]Sheet1'!$A$39 >0 , '[Wrkbook.xlsx]Sheet1'!$A$40 <0).

The strings are particular to the final worksheet.

I tried the following code with no success:

Sub FindStringInOtherWorkbook()

Dim strSearch As String
Dim rng As Range
Dim wb As Workbook
Dim ws As Worksheet
Dim c As Range
Dim rplce As String

'Set the range to search in the active sheet
Set rng = ActiveSheet.Range("A")

'Open the second workbook
Set wb = Workbooks.Open("C:\path\to\Wrkbook.xlsx")

'Loop through each sheet in the second workbook
For Each ws In wb.Sheets
    'Loop through each cell in the range
    For Each c In rng
        strSearch = c.Value
        'Search for the string in the current sheet
        Set c = ws.Cells.Find(What:=strSearch, LookIn:=xlValues, LookAt:=xlWhole)
        'If a match is found, return the cell address
        If Not c Is Nothing Then
            rplce = Replace (rng, rplce.Value, c.Address)
        End If
    Next c
Next ws

'Close the second workbook
wb.Close

End Sub

Answer 1

First, look up all ABC_* values in the workbook, then record addresses in a dictionary. After extracting the ABC_ strings from the column using a regular expression, replace the extracted strings with addresses using the dictionary.

Sub FindStringInOtherWorkbook()

    Const FOLDER = "" ' "C:\path\to\"

    Dim wb As Workbook, ws As Worksheet
    Dim dict As Object
    Dim rng As Range, c As Range, fnd As Range, first As Range
    Dim f As String, n As Long
   
    ' dictionary
    Set dict = CreateObject("Scripting.Dictionary")
    
    'Open the second workbook and extract ABC_ addresses
    Set wb = Workbooks.Open(FOLDER & "Wrkbook.xlsx")
    For Each ws In wb.Sheets
        With ws.UsedRange
           Set fnd = .Find("ABC_*", LookIn:=xlValues, lookAT:=xlWhole)
           If Not fnd Is Nothing Then
           
                Do
                   Set first = fnd
                   'Debug.Print fnd.Value, fnd.Address(0, 0, xlA1, True)
                   dict.Add fnd.Value, fnd.Address(0, 0, xlA1, True)
                   Set fnd = .FindNext(fnd)
               Loop Until fnd.Address = first.Address
                   
           End If
        End With
    Next
    
    ' regular expression
    Dim regEx As Object, m As Object
    Set regEx = CreateObject("VBScript.RegExp")
    With regEx
        .Global = True
        .MultiLine = False
        .IgnoreCase = True
        .Pattern = "(ABC_.*?\d{7})"
    End With
        
    'Set the range to search in the active sheet
    Set rng = ActiveSheet.UsedRange.Columns("A")
    For Each c In rng.Cells
        f = c.Formula
        If regEx.test(f) Then
           For Each m In regEx.Execute(f)
               s = m.submatches(0)
               If dict.exists(s) Then
                   f = Replace(f, s, dict(s))
                   n = n + 1
               End If
           Next
           c.Formula = f
        End If
    Next
    MsgBox n & " replacements made", vbInformation
    
    'Close the second workbook
    wb.Close

End Sub