各位大神，关于数据自动汇总，求解。

wg985 · 发表于 2016-4-11 12:47

本人从事搅拌站行业，每天由工控机导出的材料消耗数据是分开的，现在想在EXCEL中自动汇总。请各位大神帮帮忙，详见附件（里面有说明）。谢谢大家。

蓝桥玄霜 · 发表于 2016-4-11 15:02

Sub lqxs()
Dim Arr, i&, x$, y$, kk, tt, ii&, j&, aa, sl, n&
Dim d, k, t
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Sheet1.Activate
[i6:m5000].Clear
Arr = [a1].CurrentRegion
For i = 2 To UBound(Arr)
x = Arr(i, 4): y = Arr(i, 2)
If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
d(x)(y) = d(x)(y) & i & ","
Next
k = d.keys: t = d.items: n = 5
For i = 0 To UBound(k)
kk = t(i).keys: tt = t(i).items
For ii = 0 To UBound(kk)
n = n + 1
Cells(n, 12) = k(i): sl = 0
Cells(n, 10) = kk(ii)
tt(ii) = Left(tt(ii), Len(tt(ii)) - 1)
If InStr(tt(ii), ",") Then
aa = Split(tt(ii), ",")
For j = 0 To UBound(aa)
sl = sl + Arr(aa(j), 3)
Next
Else
sl = Arr(tt(ii), 3)
End If
Cells(n, 11) = sl
Cells(n, 9) = Arr(aa(UBound(aa)), 1)
Cells(n, 13) = Arr(aa(UBound(aa)), 5)
Next
Next
[i5].CurrentRegion.Borders.LineStyle = 1
Application.ScreenUpdating = True
End Sub

复制代码

蓝桥玄霜 · 发表于 2016-4-11 15:03

请见附件。

zax010 · 发表于 2016-4-11 15:10

Sub zz()
Dim d, ar, br
Set d = CreateObject("Scripting.Dictionary")
ar = Range("A1").CurrentRegion
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
For i = 2 To UBound(ar)
      s = ar(i, 5)
      If d(s) = "" Then
         m = m + 1: d(s) = m
         For j = 1 To UBound(ar, 2)
            br(m, j) = ar(i, j)
         Next
      Else
         br(d(s), 1) = ar(i, 1): br(d(s), 3) = br(d(s), 3) + ar(i, 3)
      End If
Next
[i6].Resize(m, UBound(br, 2)) = br
End Sub

zax010 · 发表于 2016-4-11 15:11

>>>>>>>>>>>>>>>>>>

数据自动汇总.rar (15.86 KB, 下载次数: 15)

LMY123 · 发表于 2018-9-1 17:43

d(x)(y) = d(x)(y) & i & ","

		自动登录	找回密码
密码			免费注册

[求助] 各位大神，关于数据自动汇总，求解。

评分

评分