Получить эквивалентное значение индекса в 2 массивах, используя VBA

Question

Мне нужно присвоить значение в столбце B в зависимости от условия в столбце A. Я формулирую простой код, используя условие IF ... ElseIf (см. code ниже). У меня есть 1000 условий, и я думаю, могу ли я использовать 2 отдельных массива для значения столбца A и получить индекс значения в столбце A для 1-го массива (Array1) и сопоставить его со 2-м массивом (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

Для простоты; используйте циклы 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 2

Попробуйте

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

Answer 3

Если у вас есть условия 1k (как у вас), то я думаю, что ни If, ни Select операторы не подходят. Кроме того, создание / поддержание выражений (в вашем коде), которые оценивают два массива по 1 элементу, может быть обременительным.

Удобный для обслуживания подход может заключаться в том, чтобы хранить элементы в Array1 на некотором рабочем листе и хранить рядом с ним содержимое AssignedArray. Что-то вроде ниже. Скажем, желтые значения - это элементы, которые вы бы поместили в Array1, а зеленые - это элементы, которые вы бы поместили в AssignedArray (у меня в качестве примера только 25).

Тогда вам не обязательно нужен VBA, и вы можете просто использовать функции Excel, такие как VLOOKUP - или MATCH и INDEX в сочетании. Например, я помещаю эту формулу в ячейку E4, которая пытается найти значение в D4 среди значений в столбце A и возвращает соответствующее значение из столбца 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