Excel VBA код для нескольких vlookup

Question

Для сети кабелепровода я пытаюсь найти трубы, которые стекают в люк. Там может быть несколько труб, которые могут стекать в один люк. Моя структура данных организована следующим образом:

Stop Node Label 
    ....................... 
    MH-37  CO-40 
    MH-37  CO-40 
    MH-39  CO-43 
    MH-37  CO-44 
    MH-39  CO-45 
    MH-41  CO-46 
    MH-35  CO-47 
    MH-44  CO-50 
    MH-39  CO-51 
    MH-44  CO-52 

и так далее.

Конечно, в Excel мы можем обходиться несколькими вопросами, используя уравнения массива. Однако я не уверен, как это делается в кодировке Excel VBA. Мне нужно автоматизировать весь процесс и, следовательно, кодирование Excel VBA. Эта задача является частью большего задания.

Ниже приводится код функции, я написал до сих пор:

Function Conduitt(M As String) As String() 

Dim Stop_Node As Variant /* All Manhole label */ 
Dim Conduit As Variant /* All conduit label */ 
Dim compare As Variant /* Query Manhole label */ 
Dim Result() As String 
Dim countc As Integer 

Stop_Node = ActiveSheet.Range("B2:B73").Value 
Conduit = ActiveSheet.Range("C2:C73").Value 
compare = M 

countc = 1 

Do While countc <= 72 

If Application.IsError(Application.Match(Stop_Node(countc), compare)) = 0 Then 

Result(countc) = Conduit(countc) 

End If 

countc = countc + 1 

Loop 

Conduitt = Result() 

End Function 

Если сравнить образец данных я предоставил ранее, для Manhole MH-39, соответствующие трубные этикетки, CO-43, CO-45 и CO-51. Я думал, что с изменением countc из-за do цикла он перейдет по списку и найдет точные соответствия для MH-39 и вернется CO-43, CO-45 и CO-51.

Цель состоит в том, чтобы вернуть эти этикетки кабелепровода только как строковый массив с тремя рядами (для случая MH-39).

До сих пор, когда я запускаю код, я получаю:

Run-time error '9': Subscript out of range.

Я искал различные форумы и нашел, что это происходит, когда ссылаются несуществующие элементы массива. На данный момент мои ограниченные знания и опыт не помогают расшифровать загадку.

После некоторых предложений от R3uK, код исправлен. По-видимому, когда диапазон присваивается варианту массива (как в случае Stop_Node и Conduit), вариант будет многомерным. Итак, обновили код и включили Preserve with Redim.

В случае, если вы заинтересованы, обновленный код:

Function Conduitt(Manhole As String) As String() 

Dim Stop_Node As Variant 
Dim Conduit As Variant 
Dim Result() As String 

ReDim Result(0) 

Stop_Node = ActiveSheet.Range("B2:B73").Value 
Conduit = ActiveSheet.Range("C2:C73").Value 

For i = LBound(Stop_Node) To UBound(Stop_Node) 
If Stop_Node(i, 1) <> Manhole Then 
Else 
    Result(UBound(Result)) = Conduit(i, 1) 
    ReDim Preserve Result(UBound(Result) + 1) 
End If 
Next i 
ReDim Preserve Result(UBound(Result) - 1) 

Conduitt = Result 

Answer 1

В самом деле, вы никогда не ReDim ваш Result() так это просто пустой массив, без реальной ячейки (даже пустая клетка), то первым необходимо ReDim это.

Вот моя версия, я не использовал функцию Match, но это должно работать в любом случае:

Function Conduitt(ManHole As String) As String() 

Dim Stop_Node As Variant '/* All Manhole label */ 
Dim Conduit As Variant '/* All conduit label */ 
Dim Result() As String 

ReDim Result(0) 

Stop_Node = ActiveSheet.Range("B2:B73").Value 
Conduit = ActiveSheet.Range("C2:C73").Value 

For i = LBound(Stop_Node) To UBound(Stop_Node) 
    If Stop_Node(i,1) <> ManHole Then 
    Else 
     Result(UBound(Result)) = Stop_Node(i,1) 
     ReDim Preserve Result(UBound(Result) + 1) 
    End If 
Next i 
ReDim Preserve Result(UBound(Result) - 1) 

Conduitt = Result() 

End Function 

Answer 2

Ну, видите вы решили, но здесь является альтернативным решением (должен был отправить его сейчас, Я работал над этим)

Function ConduittCheck(manhole As String) As String() 
Dim result() As String 

Dim manholeRange As Range 
Dim conduittRange As Range 
Set manholeRange = Range("manholes") 
Set conduittRange = Range("conduitts") 

Dim counter As Integer 
Dim size As Integer 
size = 0 

For counter = 0 To manholeRange.Rows.Count 
    If manholeRange.Rows.Cells(counter, 1) = manhole Then 
     ReDim Preserve result(size) 
     result(size) = conduittRange.Rows.Cells(counter, 1) 
     size = size + 1 
    End If 
Next counter 
ConduittCheck = result() 
End Function