VBA疑问

搬砖玄武

用的VBA字典算的数据汇总，现在想要跨表实现数据汇总，不知道该如何跨表编写代码，希望有位大神能够指点一二

醉眼看尘世

1. Sub test()
   
2. Dim Dic As Object, i&, Arr
   
3. Set Dic = CreateObject("Scripting.Dictionary")
   
4. Arr = Sheet2.[a1].CurrentRegion '从计算表读数据到数组Arr
   
5. For i = 2 To UBound(Arr, 1)
   
6.     Dic(Arr(i, 1)) = Dic(Arr(i, 1)) + Arr(i, 2) '相同Key累加
   
7. Next
   
8. With Sheet1
   
9.     .UsedRange.ClearContents
   
10.     .[a1:b1] = Arr '放表头
    
11.     .[a2].Resize(Dic.Count, 2) = Application.WorksheetFunction.Transpose(Array(Dic.keys, Dic.items))
    
12. End With
    
13. End Sub

复制代码

周土豆

Sub a()      Dim 字典     Set 字典 = CreateObject("Scripting.Dictionary")     With Sheet2         i = 2         Do While .Range("A" & i) <> ""             Key = .Range("A" & i)             If 字典.exists(Key) Then                 字典.Item(Key) = 字典.Item(Key) + .Range("B" & i).Value             Else                 字典.Add Key, .Range("B" & i).Value             End If             i = i + 1         Loop     End With      With Sheet1         字典条数 = 字典.Count         If 字典条数 > 0 Then             arr1 = 字典.Keys()             arr2 = 字典.items()             .Range(.Cells(2, 1), .Cells(字典条数 + 5, 1)) = Excel.Application.Transpose(arr1)             .Range(.Cells(2, 2), .Cells(字典条数 + 5, 2)) = Excel.Application.Transpose(arr2)         End If     End With End Sub

周土豆

只需加上工作表就行
Sub a()

    Dim 字典
    Set 字典 = CreateObject("Scripting.Dictionary")
    With Sheet2
        i = 2
        Do While .Range("A" & i) <> ""
            Key = .Range("A" & i)
            If 字典.exists(Key) Then
                字典.Item(Key) = 字典.Item(Key) + .Range("B" & i).Value
            Else
                字典.Add Key, .Range("B" & i).Value
            End If
            i = i + 1
        Loop
    End With

    With Sheet1
        字典条数 = 字典.Count
        If 字典条数 > 0 Then
            arr1 = 字典.Keys()
            arr2 = 字典.items()
            .Range(.Cells(2, 1), .Cells(字典条数 + 5, 1)) = Excel.Application.Transpose(arr1)
            .Range(.Cells(2, 2), .Cells(字典条数 + 5, 2)) = Excel.Application.Transpose(arr2)
        End If
    End With
End Sub

周土豆

只需加入工作即可：
Sub a()

    Dim 字典
    Set 字典 = CreateObject("Scripting.Dictionary")
    With Sheet2
        i = 2
        Do While .Range("A" & i) <> ""
            Key = .Range("A" & i)
            If 字典.exists(Key) Then
                字典.Item(Key) = 字典.Item(Key) + .Range("B" & i).Value
            Else
                字典.Add Key, .Range("B" & i).Value
            End If
            i = i + 1
        Loop
    End With

    With Sheet1
        字典条数 = 字典.Count
        If 字典条数 > 0 Then
            arr1 = 字典.Keys()
            arr2 = 字典.items()
            .Range(.Cells(2, 1), .Cells(字典条数 + 5, 1)) = Excel.Application.Transpose(arr1)
            .Range(.Cells(2, 2), .Cells(字典条数 + 5, 2)) = Excel.Application.Transpose(arr2)
        End If
    End With
End Sub