将excel公式转换为VBA宏

Question

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),""),""))

Answer 1

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