Converting excel formula into VBA macro-CodePudding

I have a sheet in excel which has a lookup column for all our internal dial-code definitions. (these are in column F &G ) - I then have a lookup column where we want to match the dialcodes from our customers to find the closest match. The formula does this right now over a series of columns by checking if there is a match, and if not then it strips out the last number and then compares again

I then compare them to the definitions i am given

And by removing 1 number at a time - i eventually get to a match on the codes how the sheet parses to get the match table of dial-code matches

I have it in an excel formula right now but would like to make it be a VBA function i can call so it runs faster - it would need to compare all of column F and G as the match which is sorted in numerical order

=IF($A3="","",IF(AND(F3="", CONCATENATE(C3,D3, E3,F3) = ""), IF(ISNA(VLOOKUP(LEFT($B3,MAX(0, LEN($B3) - G$1)) 0,Input!$F:$G,1,FALSE))=FALSE,
VLOOKUP(LEFT($B3,MAX(0, LEN($B3) - G$1)) 0,Input!$F:$G,2,FALSE),""),""))

CodePudding user response：

Try

Option Explicit

Sub LocateCode()

    Dim wb As Workbook, ws As Worksheet, wsInput As Worksheet
    Dim rngInput As Range, found As Range
    Dim LastRow As Long, LastInput As Long, r As Long
    Dim code As String, n As Integer
    
    Set wb = ThisWorkbook
   
    ' look up range
    Set wsInput = wb.Sheets("Input")
    With wsInput
        LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
        Set rngInput = .Range("F2:F" & LastRow)
    End With
   
    ' data
    Set ws = wb.Sheets("Input")
    With ws
       LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
       For r = 2 To LastRow
          code = .Cells(r, "B")
          n = Len(code)
          Do
              Set found = rngInput.Find(Left(code, n), Lookat:=xlWhole, LookIn:=xlValues)
              If Not found Is Nothing Then
                  .Cells(r, "C") = found.Offset(0, 1)
                  ' compare
                  If .Cells(r, "A") <> .Cells(r, "C") Then
                      .Cells(r, "A").Interior.Color = vbYellow
                  End If
                  Exit Do
              End If
              n = n - 1
              If n = 0 Then .Cells(r, "C") = "#N/A"
          Loop Until n = 0
       Next
    End With
   
    MsgBox "Done"
End Sub