VBA Code using Xlookup with a table won't compile

Question

Good evening, all,

I'm trying shorten names in a column by parsing the names and doing lookups on each word to return a possible abbreviation. I was doing a loop through each row (~200 words) to find a corresponding match. This seems to be taking a long time to complete.

So, now I am attempting to do the same thing using XLOOKUP instead of looping. The problem is that the following code refuses to compile yielding in the following error:

Compile error: Syntax Error

Function REPLACETEXTS(strInput As String) As String

    Dim strTemp As String
    Dim strFound As String
    Dim tblTable As ListObject
    Dim ws As Worksheet
    Dim arrSplitString() As String
    Dim strSingleString As String
    Dim i As Long
    Dim j As Long
    
    Set ws = ThisWorkbook.Sheets("Abbreviations")
    Set tblTable = ws.ListObjects("Abbrevs")
    
    strTemp = ""
    strInput = UCase(strInput)
    strInput = Replace(strInput, "-", " ")
    strInput = Replace(strInput, ",", " ")
    strInput = Replace(strInput, ".", " ")
    
    arrSplitString = Split(strInput, " ")
    
    For i = LBound(arrSplitString, 1) To UBound(arrSplitString, 1)
        ' Loop through the table to find the lookup value
        strFound = ""
        
        ' Attempting to replace this...
        'For j = 1 To tblTable.ListRows.Count
        '    If tblTable.DataBodyRange(j, 1).Value = arrSplitString(i) Then
        '        strFound = tblTable.DataBodyRange(j, 2).Value
        '        Exit For
        '    End If
        'Next j
        
        ' ... with this.
        strFound = Application.WorksheetFunction.XLOOKUP( _
                          arrSplitString(i), _
                          Abbrevs[@OrigWord], _
                          Abbrevs[@Abbrev],"Error",0,1)
            
        If strFound <> "" Then
            strTemp = strTemp & " " & strFound
        Else
            strTemp = strTemp & " " & arrSplitString(i)
        End If
            
    Next i
    
    If strTemp <> "" Then
        REPLACETEXTS = Trim(strTemp)
    Else
        REPLACETEXTS = strInput
    End If

End Function

Since you have a "not found" value of "Error", xLookup will always return a value, so strFound will never be zero-length .... (once you fix your code to set the search and return ranges correctly) — Tim Williams
– Tim Williams, Commented May 5 at 23:40
Thank you for your help. The code compiles but always returns a null result. I'm not sure what else I am doing wrong here. — R C
– R C, Commented May 6 at 14:55
Some input samples and a screenshot of your data table would help here. — Tim Williams
– Tim Williams, Commented May 6 at 14:58
I don't know how to insert a screenshot into the comments area. — R C
– R C, Commented May 6 at 15:53
Could you share the code that calls this function so we could propose one of the most efficient solutions? — VBasic2008
– VBasic2008, Commented May 6 at 16:29

VBasic2008 · Accepted Answer · 2025-05-06 23:51:35Z

Replace with Strings from a Structured Excel Lookup Table

MS365 (Edit)

With the release of the 'new' Excel functions in 2022, creating UDFs has become almost obsolete.
You could use the following formula in the first data row of the resulting column. Since the formula is in a structured table, the rows below will auto-populate with the same formula if you have previously cleared the column.

=LET(sdata,[@Supplier],ldata,Abbrevs[OrigWord],rdata,Abbrevs[Abbrev],
        sdlms,{"-",",","."," "},ddlm," ",
    s,TEXTSPLIT(UPPER(sdata),sdlms),
    l,XLOOKUP(s,ldata,rdata,""),
    TEXTJOIN(ddlm,,IF(l="",s,l)))

VBA

The following will not create a new column but modify the column strings in place.
Not tested!

Main

Sub ReplaceInRemsSuppliers() ' *** adjust!
    
    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Read data: Return the source lookup and return values in arrays.
    
    Dim sws As Worksheet: Set sws = wb.Sheets("Abbreviations")
    Dim slo As ListObject: Set slo = sws.ListObjects("Abbrevs")
    
    Dim sRowsCount As Long: sRowsCount = slo.ListRows.Count
    If sRowsCount = 0 Then Exit Sub ' empty table
    
    Dim slrg As Range: Set slrg = slo.ListColumns("OrigWord").DataBodyRange
    Dim srrg As Range: Set srrg = slo.ListColumns("Abbrev").DataBodyRange
    
    Dim slData() As Variant, srData() As Variant
    
    If sRowsCount = 1 Then ' single row (cell)
        ReDim slData(1 To 1, 1 To 1): slData(1, 1) = slrg.Value
        ReDim srData(1 To 1, 1 To 1): srData(1, 1) = srrg.Value
    Else ' multiple rows (cells)
        slData = slrg.Value
        srData = srrg.Value
    End If
    
    ' Read data: Return the target values in an array.
    
    Dim tws As Worksheet: Set tws = wb.Sheets("All REMS Suppliers") ' *** adjust!
    
    Dim trg As Range, tData() As Variant, tRowsCount As Long
    
    With tws.Range("A2") ' *** top data cell; assuming a single column; adjust!
        tRowsCount = tws.Cells(tws.Rows.Count, .Column).End(xlUp).Row - .Row + 1
        If tRowsCount < 1 Then Exit Sub ' no data
        Set trg = .Resize(tRowsCount)
    End With
    
    If tRowsCount = 1 Then ' single row (cell)
        ReDim tData(1 To 1, 1 To 1): tData(1, 1) = trg.Value
    Else ' multiple rows (cells)
        tData = trg.Value
    End If
    
    ' Modify data: Replace with abbreviations.
    Dim tRow As Long:
    For tRow = 1 To tRowsCount
        ReplaceWithAbbreviations tData, tRow, slData, srData, sRowsCount
    Next tRow
    
    ' Write back modified target data.
    trg.Value = tData
    
    ' Inform.
    MsgBox "Replaced with abbreviations.", vbInformation

End Sub

Help

Sub ReplaceWithAbbreviations( _
        TargetData() As Variant, _
        ByVal TargetRow As Long, _
        SourceLookupData() As Variant, _
        SourceReturnData() As Variant, _
        ByVal SourceRowsCount As Long)

    ' Read and validate target value (string).
    Dim tValue As Variant: tValue = TargetData(TargetRow, 1)
    If IsError(tValue) Then Exit Sub
    Dim tString As String: tString = CStr(tValue)
    If Len(tString) = 0 Then Exit Sub
    
    ' Make uppercase, replace punctuation with spaces and trim.
    tString = UCase(tString)
    tString = Replace(tString, "-", " ")
    tString = Replace(tString, ",", " ")
    tString = Replace(tString, ".", " ")
    tString = Application.Trim(tString)
    
    ' Split by space.
    Dim SplitString() As String: SplitString = Split(tString, " ")
    
    Dim i As Long, Row As Long, WasReplacedByAbbreviation As Boolean
    
    ' Replace with abbreviations.
    For i = 0 To UBound(SplitString)
        For Row = 1 To SourceRowsCount
            If SplitString(i) = SourceLookupData(Row, 1) Then
                SplitString(i) = SourceReturnData(Row, 1)
                WasReplacedByAbbreviation = True
                Exit For
            End If
        Next Row
    Next i
    
    ' Join by space only when a replacement with an abbreviation took place.
    If WasReplacedByAbbreviation Then tString = Join(SplitString, " ")
    
    ' Write back.
    TargetData(TargetRow, 1) = tString

End Sub

Thanks for your help. I have been using a loop structure, but I'm looking at 25K+ rows with an average of 3 words per cell. It ends up taking several seconds to update.
Using the LET function worked perfectly and quickly! Thank you!

Michal · Accepted Answer · 2025-05-05 23:17:50Z

1

You have to specify explicitely what table (ListObject) you are using in your lookup formula. For example:

Sub LookupExample()
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim lookupValue As String
    Dim result As Variant

    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set tbl = ws.ListObjects("Table1")

    lookupValue = "a"

    result = Application.WorksheetFunction.XLookup( _
        lookupValue, _
        tbl.ListColumns("Lookup").DataBodyRange, _
        tbl.ListColumns("Value").DataBodyRange, _
        "Not Found" _
    )

      MsgBox "The price for ProductID " & lookupValue & " is: " & result
End Sub

answered May 5 at 23:17

Michal

7,6744 gold badges30 silver badges47 bronze badges

2 Comments

R C May 6 at 15:58

I figured out how to add the screenshot to the original message.

Michal May 6 at 22:24

I already answered your question. Instead of Abbrevs[@OrigWord], you have to use tbl.ListColumns("ColumnName").DataBodyRange

Tim Williams · Accepted Answer · 2025-05-07 15:59:53Z

0

Here's an approach which just uses a loop over an array of data from the table - that will still be fast enough I think:

Function REPLACETEXTS(strInput As String) As String
    Dim strTemp As String, strFound As String
    Dim tblTable As ListObject, data
    Dim arrSplitString() As String, el
    Dim i As Long, r As Long, v As String, sep As String
    
    Set tblTable = ThisWorkbook.Sheets("Abbreviations").ListObjects("Abbrevs")
    data = tblTable.DataBodyRange.Value 'read all data to an array
    
    strInput = UCase(strInput)
    'normalize a list of characters to spaces
    For Each el In Array("-", ",", ".")
        strInput = Replace(strInput, el, " ") 
    Next el
    
    arrSplitString = Split(strInput, " ")
    strTemp = ""
    For i = LBound(arrSplitString) To UBound(arrSplitString)
        v = arrSplitString(i) 'the search term
        If Len(v) > 0 Then  'any text in this element?
            For r = 1 To UBound(data, 1)
                If data(r, 1) = v Then
                    v = data(r, 2) 'replace v with the abbreviation
                    Exit For 'stop searching
                End If
            Next r
            strTemp = strTemp & sep & v
            sep = " " 'populate separator after first round
        End If
    Next i
    REPLACETEXTS = strTemp
End Function

Here's a faster method using a scripting dictionary:

Function REPLACETEXTS(ByVal strInput As String) As String
    Dim data, arrSplitString() As String, el, i As Long, r As Long, v

    Static dict As Object 'static variables persist between calls
    
    'need to load the lookup table?
    If dict Is Nothing Then
        data = ThisWorkbook.Sheets("Abbreviations").ListObjects("Abbrevs").DataBodyRange.Value
        Set dict = CreateObject("scripting.dictionary")
        For r = 1 To UBound(data, 1) 'load the dictionary
            dict(data(r, 1)) = data(r, 2)
        Next r
    End If
    
    'clean up the input
    strInput = UCase(strInput)
    For Each el In Array("-", ",", ".")
        strInput = Replace(strInput, el, " ") 'normalize to space
    Next el
    arrSplitString = Split(strInput, " ")
    'process the input
    For i = LBound(arrSplitString) To UBound(arrSplitString)
        v = arrSplitString(i)
        If Len(v) > 0 Then
            If dict.Exists(v) Then arrSplitString(i) = dict(v)
        End If
    Next i
    REPLACETEXTS = Join(arrSplitString, " ")
End Function

Note if you need to edit the abbreviations table you'll need to reset the VBA by pressing the "stop" button in the VB editor, to clear the static variable dict

edited May 7 at 15:59

answered May 6 at 16:31

Tim Williams

169k8 gold badges104 silver badges143 bronze badges

4 Comments

R C May 6 at 22:23

Thanks for your help. I have been using a loop structure, but I'm looking at 25K+ rows with an average of 3 words per cell. It ends up taking several seconds to update.

Tim Williams May 6 at 22:41

See edit above with a faster approach

R C May 7 at 12:45

I like this. One question. Does the v in "If dict.Exists(arrSplitString(i)) Then arrSplitString(i) = dict(v)" need to be declared?

Tim Williams May 7 at 16:00

Sorry - I should not try to clean up code in the edit window. Fixed now.

Collectives™ on Stack Overflow

VBA Code using Xlookup with a table won't compile

3 Answers 3

Replace with Strings from a Structured Excel Lookup Table

2 Comments

2 Comments

4 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

3 Answers 3

Replace with Strings from a Structured Excel Lookup Table

2 Comments

2 Comments

4 Comments

Your Answer

Sign up or log in

Post as a guest

Related