excelvbaexcel-formulaexcel-tablesxlookup

VBA Code using Xlookup with a table won't compile

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

Lookup Table

Solution

  • Replace with Strings from a Structured Excel Lookup Table

    MS365 (Edit)

    =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)))

    enter image description here

    VBA

    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