提高VBA的灵活性，以将VLOOKUP转换为INDEX / MATCH

Question

在我全部搜索要读取VLOOKUP公式并将其转换为INDEX / MATCH的代码之后，我写了一些自己的文章。

但是，下面的代码缺乏我想要的灵活性，但是我似乎无法弄清楚如何使其工作。 具体来说，我想测试VLOOKUP公式中的每个范围标准是否为绝对引用，即是否以$开头，并将其传递给结果所得到的INDEX / MATCH公式。 例如，公式=VLOOKUP(A2,$A$1:B$11,2,FALSE)应转换为=INDEX(B$1:B$11,MATCH(A2,$A1:$A11,0)) 。

注意：此子取决于两个函数（ColumnLetterToNumber和ColumnNumberToLetter）。 顾名思义，它们取列字母或数字并相互转换。 这两个功能都很简短，简单，并且可以正常工作。 但是，如果有人认为其中一个或两个的代码会有所帮助，那么我很乐意提供它们。

另外，关于提高代码可读性和/或执行效率的任何想法也将被理解。

Option Explicit

Public Sub ConvertToIndex()

Dim booLookupType As Boolean
Dim booLeftOfColon As Boolean
Dim booHasRowRef As Boolean
Dim lngStartCol As Long
Dim lngRefCol As Long
Dim lngStart As Long
Dim lngEnd As Long
Dim lngMatchType As Long
Dim lngInt As Long
Dim lngRowRef As Long
Dim strRefCol As String
Dim strOldFormula As String
Dim strNewFormula As String
Dim strLookupCell As String
Dim strValueCol As String
Dim strMatchCol As String
Dim strStartRow As String
Dim strEndRow As String
Dim strCheck As String
Dim strLookupRange As String
Dim strTabRef As String
Dim strSheetRef As String
Dim rngToMod As Range
Dim rngModCell As Range

Set rngToMod = Selection

For Each rngModCell In rngToMod
    strOldFormula = rngModCell.Formula
    lngStart = InStrRev(strOldFormula, "VLOOKUP(")
    If lngStart > 0 Then
        lngStart = InStr(lngStart, strOldFormula, "(") + 1
        lngEnd = InStr(lngStart, strOldFormula, ",")
        strLookupCell = Mid(strOldFormula, lngStart, lngEnd - lngStart)
        lngStart = lngEnd + 1
        lngEnd = InStr(lngStart, strOldFormula, ",")
        strLookupRange = Mid(strOldFormula, lngStart, lngEnd - lngStart)
        lngStart = lngEnd + 1
        lngEnd = InStr(lngStart, strOldFormula, ",")
        lngRefCol = CInt(Mid(strOldFormula, lngStart, lngEnd - lngStart))
        lngStart = lngEnd + 1
        lngEnd = InStr(lngStart, strOldFormula, ")")
        booLookupType = (Mid(strOldFormula, lngStart, lngEnd - lngStart) = "TRUE")
        If booLookupType Then
            lngMatchType = 1
        Else
            lngMatchType = 0
        End If
        booLeftOfColon = True
        lngEnd = InStr(1, strLookupRange, "]")
        If lngEnd > 0 Then
            strSheetRef = Left(strLookupRange, lngEnd)
            strLookupRange = Right(strLookupRange, Len(strLookupRange) - lngEnd)
        Else
            strSheetRef = ""
        End If
        lngEnd = InStr(1, strLookupRange, "!")
        If lngEnd > 0 Then
            strTabRef = Left(strLookupRange, lngEnd)
            strLookupRange = Right(strLookupRange, Len(strLookupRange) - lngEnd)
        Else
            strTabRef = ""
        End If
        For lngInt = 1 To Len(strLookupRange)
            strCheck = Mid(strLookupRange, lngInt, 1)
            Select Case True
                Case strCheck = ":"
                    booLeftOfColon = False
                Case booLeftOfColon
                    If IsNumeric(strCheck) Then
                        strStartRow = strStartRow & strCheck
                    Else
                        strMatchCol = strMatchCol & strCheck
                    End If
                Case Else
                    If IsNumeric(strCheck) Then strEndRow = strEndRow & strCheck
            End Select
        Next lngInt
        strMatchCol = Replace(strMatchCol, "$", "")
        lngStartCol = ColumnLetterToNumber(strMatchCol)
        strValueCol = ColumnNumberToLetter(lngStartCol + lngRefCol - 1)
        If Len(strStartRow) > 0 Then strStartRow = "$" & strStartRow
        If Len(strEndRow) > 0 Then strEndRow = "$" & strEndRow
        strValueCol = strSheetRef & strTabRef & strValueCol & strStartRow & ":" & strValueCol & strEndRow
        strMatchCol = strSheetRef & strTabRef & strMatchCol & strStartRow & ":" & strMatchCol & strEndRow
        strNewFormula = "=INDEX(" & strValueCol & ",MATCH(" & "$" & strLookupCell & "," & strMatchCol & "," & lngMatchType & "))"
        rngModCell.Formula = strNewFormula
    End If
Next rngModCell

End Sub

目前，我正在寻求帮助，无需进行下一步以使其能够处理VLOOKUP / HLOOKUP或VLOOKUP / MATCH组合公式。

Answer 1

为避免我能想到的所有错误，您需要将其更改为不太美观的方式，如下所示：

Sub changeToIndex()

  Dim xText As Boolean
  Dim xBrac As Long
  Dim VLSep As New Collection
  Dim i As Long, t As String

  With Selection.Cells(1, 1) 'just for now

    'it assumes that there is NEVER a text string which has VLOOKUP like =A1&"mean text with VLOOKUP inside it"
    While InStr(1, .Formula, "VLOOKUP", vbTextCompare)

      Set VLSep = New Collection
      VLSep.Add " " & InStr(1, .Formula, "VLOOKUP", vbTextCompare) + 7

      'get the parts
      For i = VLSep(1) + 1 To Len(.Formula)
        t = Mid(.Formula, i, 1)
        If t = """" Then
          xText = Not xText
        ElseIf Not xText Then 'avoid "(", ")" and "," inside of the string to be count

          If t = "(" Then
            xBrac = xBrac + 1
          ElseIf xBrac Then 'cover up if inside of other functions
            If t = ")" Then xBrac = xBrac - 1
          ElseIf t = ")" Then
            VLSep.Add " " & i
            Exit For
          ElseIf t = "," Then
            VLSep.Add " " & i 'the space is to avoid errors with index and item if both are numbers
          End If

        End If
      Next

      Dim xFind As String 'get all the parts
      Dim xRng As String
      Dim xCol As String
      Dim xType As String

      xFind = Mid(.Formula, VLSep(1) + 1, VLSep(2) - VLSep(1) - 1)
      xRng = Mid(.Formula, VLSep(2) + 1, VLSep(3) - VLSep(2) - 1)
      xCol = Mid(.Formula, VLSep(3) + 1, VLSep(4) - VLSep(3) - 1)
      If VLSep.Count = 5 Then
        xType = Mid(.Formula, VLSep(4) + 1, VLSep(5) - VLSep(4) - 1)
      Else
        xType = "0"
      End If

      Dim fullFormulaNew As String 'get the whole formulas
      Dim fullFormulaOld As String

      fullFormulaNew = "INDEX(" & xRng & ",MATCH(" & xFind & ",INDEX(" & xRng & ",,1)," & xType & ")," & xCol & ")"
      fullFormulaOld = Mid(Selection.Cells(1, 1).Formula, VLSep(1) - 7, VLSep(VLSep.Count) - VLSep(1) + 8)

      .Formula = Replace(.Formula, fullFormulaOld, fullFormulaNew) 'simply replace the old one with the new one
    Wend

  End With
End Sub

它也应适用于非常复杂的公式。 仍然需要一些特殊的检查来剪切所有内容，使它看起来像您想要的。 我只是假设vlookup的范围可能类似于IF(A1=1,B1:C10,L5:N30) ，这IF(A1=1,B1:C10,L5:N30) ，您将需要其他子项来清除类似的内容。 :(

像这样的公式

=VLOOKUP(VLOOKUP(IF(TRUE,A2,"aaa"),$A$1:B$11,2),$B$1:$C$11,2,FALSE)

将以这种方式更改（混乱）

=INDEX($B$1:$C$11,MATCH(INDEX($A$1:B$11,MATCH(IF(TRUE,A2,"aaa"),INDEX($A$1:B$11,,1),0),2),INDEX($B$1:$C$11,,1),FALSE),2)

编辑

假设您的公式是“正常”的，则可以将最后一部分替换为：

      Dim xFind As String 'get all the parts
      Dim xRngI As String, xRngM As String
      Dim xCol As String
      Dim xType As String

      xFind = Mid(.Formula, VLSep(1) + 1, VLSep(2) - VLSep(1) - 1)
      xRngI = Mid(.Formula, VLSep(2) + 1, VLSep(3) - VLSep(2) - 1)
      xCol = Mid(.Formula, VLSep(3) + 1, VLSep(4) - VLSep(3) - 1)
      If VLSep.Count = 5 Then
        xType = Mid(.Formula, VLSep(4) + 1, VLSep(5) - VLSep(4) - 1)
      Else
        xType = "0"
      End If
      If xType = "FALSE" Then xType = 0

      Do While Not IsNumeric(xCol)
        Select Case MsgBox("Error: The Column to pick from is not numerical! Do you want to manually set the column (Yes) or directly use the last column of the input range (No)?", vbYesNoCancel)
        Case vbYes
          xCol = Application.InputBox("Input the column number for the input range (" & xRngI & "). '1' will be the range " & Range(xRngI).Columns(1).Address(0, 0) & ".", "Column to pick from", 1, , , , , 2)
        Case vbNo
          xCol = Range(xRngI).Columns.Count
        Case vbCancel
          xCol = " "
          Exit Do
        End Select
        If xCol <> CInt(xCol) Or xCol > Range(xRngI).Columns.Count Or xCol = 0 Then xCol = " "
      Loop

      If IsNumeric(xCol) Then

        Dim absRs As Boolean, absRe As Boolean, absCs As Boolean, absCe As Boolean

        absCs = (Left(xRngI, 1) = "$")
        absCe = (Mid(xRngI, InStr(xRngI, ":") + 1, 1) = "$")
        absRs = (InStr(2, Left(xRngI, InStr(xRngI, ":") - 1), "$") > 0)
        absRe = (InStr(Mid(xRngI, InStr(xRngI, ":") + 2), "$") > 0)

        xRngM = Range(xRngI).Columns(1).Cells(1, 1).Address(absRs, absCs) & ":" & Range(xRngI).Columns(1).Cells(Range(xRngI).Rows.Count, 1).Address(absRe, absCs) 'for MATCH
        xRngI = Range(xRngI).Cells(1, CLng(xCol)).Address(absRs, absCe) & ":" & Range(xRngI).Cells(Range(xRngI).Rows.Count, CLng(xCol)).Address(absRe, absCe) 'for INDEX

        Dim fullFormulaNew As String, fullFormulaOld As String

        fullFormulaNew = "INDEX(" & xRngI & ",MATCH(" & xFind & "," & xRngM & "," & xType & "))"
        fullFormulaOld = Mid(Selection.Cells(1, 1).Formula, VLSep(1) - 7, VLSep(VLSep.Count) - VLSep(1) + 8)

        .Formula = Replace(.Formula, fullFormulaOld, fullFormulaNew) 'simply replace the old one with the new one

      End If

    Wend

  End With
End Sub

如您所见：结果“越简单”，您需要的代码越多。 如果lookup_range不只是一个地址，那么它将失败。

如果您还有任何疑问，请问;）