VBA code to take some string components, search them inside a workbook and replace the components wi-CodePudding

I am having a column in excel with formulas that return TRUE/FALSE. The component of each formula are alphanumeric strings that starts always from ABC_ and always ends in 7 digits. The middle part of the string may vary.

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

These alphanumeric strings indicate cells from an other workbook. I want to replace these strings with the cell address that this string is found.

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

The strings are unique inside the destination workbook.

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

CodePudding user response：

First search the wrkbook for all ABC_* values and store address in a dictionary. Then scan down the column using a regular expression to extract the ABC_ strings and using the dictionary replace string with address.

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
                Set first = fnd
                Do      
                   'Debug.Print fnd.Value, fnd.Address(0, 0, xlA1, True)
                   If dict.exists(fnd.Value) Then
                       MsgBox "Duplicate Key " & fnd.Value & vbLf & dict(fnd.Value) _
                       & vbLf & fnd.Address(0, 0, xlA1, True), vbExclamation
                       Exit Sub
                   Else
                       dict.Add fnd.Value, fnd.Address(0, 0, xlA1, True)
                   End If
                   
                   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

    ' debug code dump dictionary
    Dim k, i
    Workbooks.Add
    i = 1
    For Each k In dict.keys
        Cells(i, 1) = k
        Cells(i, 2) = dict(k)
        i = i   1
    Next

End Sub