用于多个vlookup的Excel VBA代码

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中，我们可以使用数组方程式解决多个vlookup问题。 但是，我不确定在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 。 我以为，由于do循环导致countc发生变化，它将遍历列表并找到MH-39的确切匹配项，并返回CO-43 ， CO-45和CO-51 。

目的是仅将这些导管标签作为三行的字符串数组返回 （对于MH-39情况）。

到目前为止，当我运行代码时，我得到：

运行时错误'9'：下标超出范围。

我搜索了不同的论坛，并发现当引用不存在的数组元素时会发生这种情况。 在这一点上，我有限的知识和经验无法帮助您解开谜题。

经过R3uK的一些建议后，代码已修复。 显然，将范围分配给变量数组时（如Stop_Node和Conduit），变量将是多维的。 因此，相应地更新了代码，并将Preserve与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