用于多个vlookup的Excel VBA代码

Question

For a conduit network, I am trying to find the pipes that drain to a manhole. There can be multiple pipes that can drain to a single manhole. My data-structure is organized in the following way:

   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

and so on.

Of course, in Excel, we can workaround the multiple vlookup question using array equations. However, I am not sure how it is done in Excel VBA coding. I need to automate the whole process and hence Excel VBA coding. This task is part of a bigger assignment.

Following is the function code I wrote so far:

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

If you compare the sample of data I provided before, For Manhole MH-39 , corresponding conduit labels are, CO-43 , CO-45 and CO-51 . I thought, with countc changing due to do loop, it will go through the list and find the exact matches for MH-39 and return CO-43 , CO-45 and CO-51 .

Objective is to return these conduit labels only as a string array with three rows (for MH-39 case).

So far, when I run the code, I get :

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

I searched different forums and found it happens when non-existing array elements are referenced. At this point, my limited knowledge and experience are not helping decipher the puzzle.

After some suggestions from R3uK , got the code fixed. Apparently, when a range is assigned to a variant array (as in the case of Stop_Node and Conduit), the variant will be multi-dimensional. So, updated the code accordingly and incorporated Preserve with Redim.

İn case you are interested, the updated code:

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

In fact, you never ReDim your Result() so it is just an empty array with no actual cell (not even an empty cell), you first need to ReDim it.

Here is my version, I didn't use the function Match but that should work anyway :

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

Well, see you solved it, but here is an alternative solution (had to post it now that I have worked on it)

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