汇总数据求提速

suwenkai · 发表于 2015-3-13 19:09

张雄友发表于 2015-3-13 18:48
刚下班，测试一下，下标出错了。

不用数组，直接写到表格里吧。

Type myindex
name As String
no As String
d As Object
capacity As Long
End Type
Type mylist
workNo As Long
d As Object
list() As myindex
count As Long
End Type
Sub 按钮7_Click()
Dim d As Object, ds As Object
Dim a() As mylist
mytime = Timer
Set d = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")
arr = Sheets("交飞明细").Range("a1").CurrentRegion
For i = 1 To UBound(arr, 2)
d(arr(1, i)) = i
Next
For i = 2 To UBound(arr)
If Not ds.Exists(arr(i, d("工号"))) Then
n = n + 1
ds(arr(i, d("工号"))) = n
ReDim Preserve a(1 To n)
With a(n)
.workNo = arr(i, d("工号"))
.count = 1
Set .d = CreateObject("scripting.dictionary")
.d(arr(i, d("工序名称"))) = .count
ReDim Preserve .list(1 To 1)
With .list(1)
Set .d = CreateObject("scripting.dictionary")
.d(arr(i, d("制单号"))) = ""
.name = arr(i, d("工序名称"))
.no = arr(i, d("制单号"))
.capacity = arr(i, d("产量"))
End With
End With
Else
With a(ds(arr(i, d("工号"))))
If Not .d.Exists(arr(i, d("工序名称"))) Then
.count = .count + 1
If .count > Max Then Max = .count
.d(arr(i, d("工序名称"))) = .count
ReDim Preserve .list(1 To .count)
With .list(.count)
.name = arr(i, d("工序名称"))
Set .d = CreateObject("scripting.dictionary")
.d(arr(i, d("制单号"))) = ""
.no = arr(i, d("制单号"))
.capacity = arr(i, d("产量"))
End With
Else
With .list(.d(arr(i, d("工序名称"))))
If Not .d.Exists((arr(i, d("制单号")))) Then
.no = .no & "" & arr(i, d("制单号"))
End If
.capacity = .capacity + arr(i, d("产量"))
End With
End If
End With
End If
Next
For i = 1 To UBound(a)
Sheets("get").Cells(i, 1) = a(i).workNo
For j = 1 To a(i).count
Sheets("get").Cells(i, j + 1) = a(i).list(j).no & " " & a(i).list(j).name & " " & a(i).list(j).capacity & "件"
Next
Next
MsgBox Timer - mytime
End Sub

复制代码

suwenkai · 发表于 2015-3-13 19:10

这是附件。。。

suwenkai · 发表于 2015-3-13 19:32

如果怕就话，就定义一下变量，给个初始值
max =1

Type myindex
name As String
no As String
d As Object
capacity As Long
End Type
Type mylist
workNo As Long
d As Object
list() As myindex
count As Long
End Type
Sub 按钮7_Click()
Dim d As Object, ds As Object
Dim a() As mylist, max
max = 1
mytime = Timer
Set d = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")
arr = Sheets("交飞明细").Range("a1").CurrentRegion
For i = 1 To UBound(arr, 2)
d(arr(1, i)) = i
Next
For i = 2 To UBound(arr)
If Not ds.Exists(arr(i, d("工号"))) Then
n = n + 1
ds(arr(i, d("工号"))) = n
ReDim Preserve a(1 To n)
With a(n)
.workNo = arr(i, d("工号"))
.count = 1
Set .d = CreateObject("scripting.dictionary")
.d(arr(i, d("工序名称"))) = .count
ReDim Preserve .list(1 To 1)
With .list(1)
Set .d = CreateObject("scripting.dictionary")
.d(arr(i, d("制单号"))) = ""
.name = arr(i, d("工序名称"))
.no = arr(i, d("制单号"))
.capacity = arr(i, d("产量"))
End With
End With
Else
With a(ds(arr(i, d("工号"))))
If Not .d.Exists(arr(i, d("工序名称"))) Then
.count = .count + 1
If .count > max Then max = .count
.d(arr(i, d("工序名称"))) = .count
ReDim Preserve .list(1 To .count)
With .list(.count)
.name = arr(i, d("工序名称"))
Set .d = CreateObject("scripting.dictionary")
.d(arr(i, d("制单号"))) = ""
.no = arr(i, d("制单号"))
.capacity = arr(i, d("产量"))
End With
Else
With .list(.d(arr(i, d("工序名称"))))
If Not .d.Exists((arr(i, d("制单号")))) Then
.no = .no & "" & arr(i, d("制单号"))
End If
.capacity = .capacity + arr(i, d("产量"))
End With
End If
End With
End If
Next
ReDim brr(1 To UBound(a), 1 To max + 1)
For i = 1 To UBound(a)
brr(i, 1) = a(i).workNo
For j = 1 To a(i).count
brr(i, j + 1) = a(i).list(j).no & " " & a(i).list(j).name & " " & a(i).list(j).capacity & "件"
Next
Next
Sheets("get").Range("a2").Resize(n, max + 1) = brr
MsgBox Timer - mytime
End Sub

复制代码

suwenkai · 发表于 2015-3-13 19:34

附件。、、、、、

suwenkai · 发表于 2015-3-13 19:51

自定义数据结构和字典代替维度我是学leel892大侠的。用得不是很好。就是变量。。。（小学英语的水平，只能是这样的了。）

http://club.excelhome.net/thread-722501-1-1.html

复制代码

http://club.excelhome.net/thread-958920-1-1.html

复制代码

张雄友 · 发表于 2015-3-13 19:57

将此网址抄一次都值得。
http://club.excelhome.net/thread-722501-1-1.html

http://club.excelhome.net/thread-958920-1-1.html

张雄友 · 发表于 2015-3-13 21:15

suwenkai 发表于 2015-3-13 19:34
附件。、、、、、

制单号不能去重复。

_枫_ · 发表于 2015-3-13 21:43

用sql写了个

_枫_ · 发表于 2015-3-13 22:47

++++++++()

suwenkai · 发表于 2015-3-14 09:33

修正了去重的问题

Type myindex
name As String
no As String
d As Object
capacity As Long
End Type
Type mylist
workNo As Long
d As Object
list() As myindex
count As Long
End Type
Sub 按钮7_Click()
Dim d As Object, ds As Object
Dim a() As mylist, max
max = 1
mytime = Timer
Set d = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")
arr = Sheets("交飞明细").Range("a1").CurrentRegion
For i = 1 To UBound(arr, 2)
d(arr(1, i)) = i
Next
For i = 2 To UBound(arr)
If Not ds.Exists(arr(i, d("工号"))) Then
n = n + 1
ds(arr(i, d("工号"))) = n
ReDim Preserve a(1 To n)
With a(n)
.workNo = arr(i, d("工号"))
.count = 1
Set .d = CreateObject("scripting.dictionary")
.d(arr(i, d("工序名称"))) = .count
ReDim Preserve .list(1 To 1)
With .list(1)
Set .d = CreateObject("scripting.dictionary")
.d(arr(i, d("制单号"))) = ""
.name = arr(i, d("工序名称"))
.no = arr(i, d("制单号"))
.capacity = arr(i, d("产量"))
End With
End With
Else
With a(ds(arr(i, d("工号"))))
If Not .d.Exists(arr(i, d("工序名称"))) Then
.count = .count + 1
If .count > max Then max = .count
.d(arr(i, d("工序名称"))) = .count
ReDim Preserve .list(1 To .count)
With .list(.count)
.name = arr(i, d("工序名称"))
Set .d = CreateObject("scripting.dictionary")
.d(arr(i, d("制单号"))) = ""
.no = arr(i, d("制单号"))
.capacity = arr(i, d("产量"))
End With
Else
With .list(.d(arr(i, d("工序名称"))))
If Not .d.Exists((arr(i, d("制单号")))) Then
.d((arr(i, d("制单号")))) = ""
.no = .no & "/" & arr(i, d("制单号"))
End If
.capacity = .capacity + arr(i, d("产量"))
End With
End If
End With
End If
Next
ReDim brr(1 To UBound(a), 1 To max + 1)
For i = 1 To UBound(a)
brr(i, 1) = a(i).workNo
For j = 1 To a(i).count
If a(i).list(j).d.count > 1 Then
a(i).list(j).no = "(" & a(i).list(j).no & ")"
End If
brr(i, j + 1) = a(i).list(j).no & " " & a(i).list(j).name & " " & a(i).list(j).capacity & "件"
Next
Next
Sheets("get").Range("a2").Resize(n, max + 1) = brr
MsgBox Timer - mytime
End Sub

复制代码

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

[求助] 汇总数据求提速

评分

点评

点评

评分

点评

评分

评分