用VBA根据名称合并相同项，相同项的数据也相加

zzgezi

大家好，我刚学习VBA，写了一个简单的根据名称合并相同项，并将相同项的数据也相加的程序，但是感觉运行效率很低，数据量大的时候，电脑要卡很久。

有人说还没数据透视表的效率高。

请大家帮我看下，代码怎么优化。谢谢了。

liulang0808

Sub test()
    arr = [a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For j = 2 To UBound(arr)
        d(arr(j, 1)) = d(arr(j, 1)) + arr(j, 2)
    Next j
    [a1:b1].Copy [d1]
    [d2].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
    [e2].Resize(d.Count) = WorksheetFunction.Transpose(d.items)
    [d1].CurrentRegion.Borders.LineStyle = xlContinuous
End Sub

liulang0808

http://club.excelhome.net/thread-1385473-1-1.html
字典案例，楼主可以参考下

liulang0808

Sub test()
    Set cnn = CreateObject("adodb.connection")
    cnn_str1 = "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & ThisWorkbook.FullName
    Sql = "select 名称,sum(金额) as 金额 from [sheet1$] group by 名称"
    cnn.Open cnn_str1
    Set rst = cnn.Execute(Sql)
    [d1].CopyFromRecordset rst
End Sub

zzgezi

谢谢liulang0808版主，我试下您的方法，有不懂的再来请教。

everbest2015

Sub HeBing()
    Dim sh As Worksheet, d As Object, ar, i&, s$
    Set sh = ThisWorkbook.Sheets("Sheet1")
    Set d = CreateObject("scripting.dictionary")
    With sh
            If .AutoFilterMode Then .AutoFilterMode = False
            .Range("G:H").ClearContents
            ar = .Range("a1").CurrentRegion
            For i = 2 To UBound(ar)
                    s = ar(i, 1)
                    If s <> "" Then
                            d(s) = d(s) + Val(ar(i, 2))
                    End If
            Next
            If d.Count = 0 Then Exit Sub
            .[G2].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
            Set d = Nothing
    End With
End Sub

zzgezi

liulang0808 发表于 2019-10-7 08:40
Sub test()
    Set cnn = CreateObject("adodb.connection")
    cnn_str1 = "provider=microsoft.ace.o ...

版主，你这是用的什么技巧啊？因为我之前学过C语言，所以我基本上用的类似于C语言的编程逻辑实现的。

zzgezi

everbest2015 发表于 2019-10-7 09:24
Sub HeBing()
    Dim sh As Worksheet, d As Object, ar, i&, s$
    Set sh = ThisWorkbook.Sheets("Sh ...

你好，请问你这是用的什么技巧啊？能方便加上注释吗，我真心不太理解。谢谢了。

孙旭白

Sub try()
Dim arr
Dim i, m
Dim dic
arr = Range("a1").CurrentRegion
Set dic = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
    dic(arr(i, 1)) = dic(arr(i, 1)) + arr(i, 2)
Next
Range("g1").Resize(dic.Count, 1) = Application.Transpose(dic.keys)
Range("h1").Resize(dic.Count, 1) = Application.Transpose(dic.items)

End Sub

everbest2015

zzgezi 发表于 2019-10-7 11:22
你好，请问你这是用的什么技巧啊？能方便加上注释吗，我真心不太理解。谢谢了。

您好  字典加数组  是合并同类项的必杀技，论坛帖子很多 ，建议搜索下