[已解决]用VBA字典实现查找两列数据 对比第二个错在哪里

laoau138

用VBA字典实现查找两列数据  对比第二个错在哪里



Sub 第一个结果正确()
    Dim arr(), brr(1 To 1000, 1 To 2)
    Dim x, k, h
    Dim d
    Set d = CreateObject("scripting.dictionary")
    arr = Range("A1").CurrentRegion
    For x = 2 To UBound(arr)
        If arr(x, 1) <> "" Then
            k = k + 1
            d(Cells(x, 6).Value & Cells(x, 7).Value) = k
        End If
    Next x

    For x = 2 To UBound(arr)
        If d.exists(arr(x, 1) & arr(x, 2)) Then
            h = d(arr(x, 1) & arr(x, 2))
            brr(h, 1) = arr(x, 3)
            brr(h, 2) = arr(x, 4)
        End If
    Next x
    Range("h2").Resize(UBound(arr), 2) = brr
End Sub



Sub 第二个错在哪里()
    arr = [a1].CurrentRegion
    brr = [f1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(brr)
        d(brr(i, 1) & brr(i, 2)) = i
    Next
    For i = 2 To UBound(arr)
        t = arr(i, 1) & arr(i, 2)
        If d.exists(t) Then
            brr(d(t), 3) = brr(d(t), 3) + 1
            brr(d(t), 4) = brr(d(t), 4) + 1
        End If
    Next
    [f1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

最佳答案

月排行榜 / 总排行榜

lisachen

2017-6-19 19:42

Sub 第二个()
    arr = [a1].CurrentRegion
    [h2:i7].ClearContents
    brr = [f1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(brr)
        d(brr(i, 1) & brr(i, 2)) = i
    Next
    For i = 2 To UBound(arr)
        t = arr(i, 1) & arr(i, 2)
        If d.exists(t) Then
            brr(d(t), 3) = brr(d(t), 3) + arr(i, 3)
            brr(d(t), 4) = brr(d(t), 4) + arr(i, 4)
        End If
    Next
    [f1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

跳转到最佳答案楼层

lisachen

Sub 第二个()
    arr = [a1].CurrentRegion
    [h2:i7].ClearContents
    brr = [f1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(brr)
        d(brr(i, 1) & brr(i, 2)) = i
    Next
    For i = 2 To UBound(arr)
        t = arr(i, 1) & arr(i, 2)
        If d.exists(t) Then
            brr(d(t), 3) = brr(d(t), 3) + arr(i, 3)
            brr(d(t), 4) = brr(d(t), 4) + arr(i, 4)
        End If
    Next
    [f1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

laoau138

lisachen 发表于 2017-6-19 19:42
Sub 第二个()
    arr = [a1].CurrentRegion
    [h2:i7].ClearContents

果然是高手

laoau138

lisachen 发表于 2017-6-19 19:42
Sub 第二个()
    arr = [a1].CurrentRegion
    [h2:i7].ClearContents

结果正确了，

laoau138

lisachen 发表于 2017-6-19 19:42
Sub 第二个()
    arr = [a1].CurrentRegion
    [h2:i7].ClearContents

现在没有问题了