使用VBA在2个数组中获取等效的索引值

Question

我需要根据列A中的条件在列B中分配一个值。我使用IF ... ElseIf条件（请参见下面的代码）来编写简单的代码。我有1000个条件，我在考虑是否可以为Column A的值使用2个单独的数组，并获取A列中的值的索引到第一个数组（Array1），并将其与第二个数组（AssignedArray）匹配。像这样，对于在列A中找到的每个值，请检查Array1是否存在该值，并获取索引并将索引与AssignedArray匹配。例如，

Array1 = Array("DL2005", "EFRUEN", "DESTDIDIER", "EOGRADY3", "EKARLSON1", "EOKUTOMI1")
AssignedArray = Array("Trader", "Trader", "Operations", "Trader", "Analyst", "Operations")

代码

For x = 1 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    For Each wrd In Sheets(1).Cells(x, 1)
        val = wrd

        If UCase(val) = "DL2005" Then
            Sheets(1).Cells(x, 3).Value = "Trader"
        ElseIf UCase(val) = "EFRUEN" Then
            Sheets(1).Cells(x, 3).Value = "Trader"
        ElseIf UCase(val) = "DESTDIDIER" Then
            Sheets(1).Cells(x, 3).Value = "Operations"
        ElseIf UCase(val) = "EOGRADY3" Then
            Sheets(1).Cells(x, 3).Value = "Trader"
        ElseIf UCase(val) = "EKARLSON1" Then
            Sheets(1).Cells(x, 3).Value = "Analyst"
        ElseIf UCase(val) = "EOKUTOMI1" Then
            Sheets(1).Cells(x, 3).Value = "Operations"
        End If
    Next wrd
Next x

是否可以这样做？或者有什么方法可以简化我的代码，而不是使用IF ELSEIF条件。

Answer 1

如果您有1k条条件（如您所愿），那么我认为If和Select语句都不适合。此外，在代码中创建/维护计算两个1k元素数组的表达式可能很麻烦。

一种易于维护的方法可能是将项目保留在某些工作表的Array1中，并将AssignedArray的内容保留在其旁边。如下所示。假设黄色值是您应该放入Array1中的项目，绿色值是您应该放入AssignedArray中的项目（我仅以25为例）。

然后，您不一定需要任何VBA，而可以纯粹使用VLOOKUP或MATCH和INDEX之类的Excel函数。例如，我将此公式放在单元格E4中，它试图在A列中的值中找到D4中的值，并从B列中返回相应的值：

=INDEX($B$1:$B$25,MATCH(D4,$A$1:$A$25,0))

如果您仍要使用VBA，则此代码应在单元格D4:D8（这是我的电子表格的正确范围，但可能不是您的电子表格的正确范围）上循环，使它们大写（仅在内存中，而不是在表格），然后将相应的值写入G4:G8：

Option Explicit

Private Sub FillInAssociatedValuesValue()
    Dim inputKeys() As Variant ' <-- AKA Array1
    inputKeys = ThisWorkbook.Worksheets("Sheet1").Range("A1:A25").Value2 ' Change to wherever items from Array1 are kept

    Dim inputValues() As Variant '<-- AKA AssignedArray
    inputValues = ThisWorkbook.Worksheets("Sheet1").Range("B1:B25").Value2 ' Change to wherever items from AssignedArray are kept

    If (UBound(inputKeys, 1) - LBound(inputKeys, 1)) <> (UBound(inputValues, 1) - LBound(inputValues, 1)) Then
        MsgBox ("The number of keys should be the same as the number of associated values. Code will stop running now.")
        Exit Sub
    End If

    Dim dict As Object 'Shouldn't need to add a reference
    Set dict = CreateObject("Scripting.Dictionary") 

    ' One pass to fill the dictionary. If there are duplicates, will only add first instance.
    Dim rowIndex As Long
    For rowIndex = LBound(inputKeys, 1) To UBound(inputKeys, 1)
        If Not dict.Exists(inputKeys(rowIndex, 1)) Then
            dict.Add UCase$(inputKeys(rowIndex, 1)), inputValues(rowIndex, 1)
        End If
    Next rowIndex

    Dim Key As String

    With ThisWorkbook.Worksheets("Sheet1")
        For rowIndex = 4 To 8 ' I needed to loop over range D4:D8
            Key = UCase$(.Cells(rowIndex, "D").Value2)

            If dict.Exists(Key) Then
                .Cells(rowIndex, "G").Value2 = dict.Item(Key)
            Else
                ' Some logic in case input is not found, and cannot be mapped to some associated value
                .Cells(rowIndex, "G").Value2 = "VALUE NOT FOUND"
            End If
        Next rowIndex
    End With
End Sub

Answer 2

为简单起见；使用For循环将Array1与column A中的每个单元格进行比较，如果存在匹配项，请使用Offset将AssignedArray中的相应元素放入正确的。

Dim Array1 As Variant, AssignedArray As Variant
Dim x As Long, i As Long

Array1 = Array("DL2005", "EFRUEN", "DESTDIDIER", "EOGRADY3", "EKARLSON1", "EOKUTOMI1")
AssignedArray = Array("Trader", "Trader", "Operations", "Trader", "Analyst", "Operations")

For x = 2 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    For i = LBound(Array1) To UBound(Array1)
        If Cells(x, 1).Value = Array1(i) Then
            Cells(x, 1).Offset(, 1).Value = AssignedArray(i)
        End If
    Next i
Next x

Answer 3

尝试

Sub test()
    Dim Ws As Worksheet
    Dim Array1, AssignedArray
    Dim s As String, i As Integer, r As Long, x As Long
    Dim k As Integer

    Array1 = Array("DL2005", "EFRUEN", "DESTDIDIER", "EOGRADY3", "EKARLSON1", "EOKUTOMI1")
    AssignedArray = Array("Trader", "Trader", "Operations", "Trader", "Analyst", "Operations")

    Set Ws = Sheets(1)
    r = Ws.Cells(Rows.Count, 1).End(xlUp).Row
    With Ws
        For x = 1 To r
            s = UCase(.Cells(x, 1))
            For i = LBound(Array1) To UBound(Array1)
                If s = Array1(i) Then
                    k = i
                    Exit For
                End If
            Next i
            .Cells(x, 3) = AssignedArray(k)
        Next x
    End With

End Sub

如果您有大量数据，最好将结果安排在一张纸上，而不是一个一个地输入到单元格中，以加快结果的速度。

Sub test2()
    Dim Ws As Worksheet
    Dim Array1, AssignedArray
    Dim s As String, i As Integer, r As Long, x As Long
    Dim k As Integer
    Dim vDB, vR()

    Array1 = Array("DL2005", "EFRUEN", "DESTDIDIER", "EOGRADY3", "EKARLSON1", "EOKUTOMI1")
    AssignedArray = Array("Trader", "Trader", "Operations", "Trader", "Analyst", "Operations")

    Set Ws = Sheets(1)

    With Ws
        vDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
        r = UBound(vDB, 1)
        ReDim vR(1 To r, 1 To 1)
        For x = 1 To r
            s = UCase(vDB(x, 1))
            For i = LBound(Array1) To UBound(Array1)
                If s = Array1(i) Then
                    k = i
                    Exit For
                End If
            Next i
            vR(x, 1) = AssignedArray(k)
        Next x
        .Range("c1").Resize(r) = vR
    End With

End Sub