如何用VBA汇总数据

Ally248

如附件，有个汇总表，需要对这些数据进行汇总，做出结果表的结果，数据量很大，请大师们帮忙写个代码，谢谢。

Ally248

附件没上传成功，再上传一次

约定的童话

每个行标签都是两行吗？

Ally248

约定的童话 发表于 2019-4-2 15:54
每个行标签都是两行吗？

不是的，会超过2行，这里只是举例

Ally248

朱荣兴 发表于 2019-4-2 16:02
Sub test() ''qq705664849
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scrip ...

可以用，谢谢老师!!

denglunyong

测试成功!!! 速度升很多!谢谢老师指点!!!

iwangyi

Sub C()
UsedRange.Offset(1).ClearContents
Set CN = CreateObject("ADODB.CONNECTION")
Set RS = CreateObject("ADODB.RECORDSET")
Set D = CreateObject("SCRIPTING.DICTIONARY")
CN.Open "PROVIDER = MICROSOFT.JET.OLEDB.4.0;EXTENDED PROPERTIES=EXCEL 8.0;DATA SOURCE=" & ThisWorkbook.FullName
Sql = "SELECT DISTINCT 行标签 FROM [汇总$]"
RS.Open Sql, CN, 1, 3
N = RS.RecordCount
For i = 1 To N
Sql = "SELECT DISTINCT 商品名称 FROM (SELECT * FROM [汇总$] WHERE 行标签='" & RS.Fields(0) & "')"
ARR = CN.Execute(Sql).GETROWS
For Each K In ARR
If K <> "" Then
D(K) = ""
End If
Next
M = [A65536].End(3).Row + 1
Cells(M, 1) = RS.Fields(0).Value
Cells(M, 2) = Join(D.KEYS, "/")
D.RemoveAll
Sql = "SELECT DISTINCT 仓库 FROM (SELECT * FROM [汇总$] WHERE 行标签='" & RS.Fields(0) & "')"
BRR = CN.Execute(Sql).GETROWS
For Each KK In BRR
D(KK) = ""
Next
Cells(M, 3) = Join(D.KEYS, "/")
D.RemoveAll
RS.movenext
Next
End Sub

iwangyi

附件参考******