[已解决]VBA难题！！！请大侠解决，在线等～～～

edwardk2

新建 Microsoft Office Excel 工作表 (3).rar (22.91 KB, 下载次数: 8)

2013-12-11 17:26 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-12-11 19:30

1. Sub teset22()
   
2.     Dim arr, temp()
   
3.     Dim lRow As Long, lCol As Long
   
4.     Dim dicName As Object, dic As Object, icRow As Object
   
5.     Dim i As Long
   
6. 
   
7.     Set dic = CreateObject("scripting.dictionary")
   
8.     Set dicName = CreateObject("scripting.dictionary")
   
9.     Set dicRow = CreateObject("scripting.dictionary")
   
10. 
    
11.     arr = Sheets("sheet1").Range("a6:m" & Sheet1.[a65536].End(xlUp).Row)
    
12.     For i = 1 To UBound(arr, 1)
    
13. 
    
14.         If Not dicName.exists(arr(i, 2)) Then
    
15.             '数组扩容,3列一组
    
16.             ReDim Preserve temp(1 To UBound(arr), 1 To (dicName.Count + 1) * 3)
    
17.             dicName.Add arr(i, 2), dicName.Count + 1
    
18.             '列号
    
19.             dicRow.Add arr(i, 2), 1
    
20.         End If
    
21. 
    
22.         '对应姓名在哪一列
    
23.         lCol = dicName(arr(i, 2)) * 3 - 2
    
24.         '行号
    
25.         lRow = dicRow(arr(i, 2))
    
26.         temp(lRow, lCol) = arr(i, 1)
    
27.         temp(lRow, lCol + 1) = arr(i, 12)
    
28.         temp(lRow, lCol + 2) = arr(i, 13)
    
29.         dicRow(arr(i, 2)) = dicRow(arr(i, 2)) + 1
    
30.     Next
    
31.    
    
32.     Application.ScreenUpdating = False
    
33.    
    
34.     ActiveSheet.UsedRange.Offset(2).ClearContents
    
35.     Range("a4").Resize(UBound(arr), UBound(temp, 2)).Value = temp
    
36.     ReDim temp(1 To dicName.Count * 3)
    
37.     arr = dicName.keys
    
38.     For i = 0 To UBound(arr)
    
39.         temp(i * 3 + 2) = arr(i)
    
40.     Next
    
41.     Range("a2").Resize(, UBound(temp)).Value = temp
    
42.    
    
43.     Application.ScreenUpdating = True
    
44.     Set dicName = Nothing
    
45.     Set dic = Nothing
    
46.     Set dicRow = Nothing
    
47.    
    
48.     MsgBox "统计完成"
    
49. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

错误1：
arr = Range("a2:m50" & [a65536].End(xlUp).Row)
这里写错了，应该写成：
arr = Range("a2:m" & [a65536].End(xlUp).Row)

hwc2ycy

错了，还有个前缀没有加。
arr = sheet1.Range("a2:m" & sheet1.[a65536].End(xlUp).Row)

hwc2ycy

1. Sub teset2()
   
2.     Dim arr, temp()
   
3.     Dim arr2, lRow As Long, lCol As Long
   
4.     Dim dicName As Object
   
5.     Dim dic As Object
   
6.     Dim i As Long
   
7. 
   
8.     Set dic = CreateObject("scripting.dictionary")
   
9.     Set dicName = CreateObject("scripting.dictionary")
   
10.     arr = Sheets("sheet1").Range("a6:m" & Sheet1.[a65536].End(xlUp).Row)
    
11.     For i = 1 To UBound(arr, 1)
    
12. 
    
13.         If Not dicName.exists(arr(i, 2)) Then
    
14.             '数组扩容,3列一组
    
15.             ReDim Preserve temp(1 To UBound(arr), 1 To (dicName.Count + 1) * 3)
    
16.             dicName.Add arr(i, 2), Array(dicName.Count + 1, 0)
    
17.             '列号：数量
    
18.         End If
    
19. 
    
20.         lCol = (dicName(arr(i, 2))(0)) * 3 - 2
    
21. 
    
22.         If Not dic.exists(arr(i, 2) & "#" & arr(i, 1)) Then
    
23.             dic.Add arr(i, 2) & "#" & arr(i, 1), dicName(arr(i, 2))(1) + 1
    
24.             '姓名#日期，行号
    
25.             arr2 = dicName(arr(i, 2))
    
26.             arr2(1) = arr2(1) + 1
    
27.             dicName(arr(i, 2)) = arr2
    
28.         End If
    
29. 
    
30.         lRow = dicName(arr(i, 2))(1)
    
31.         temp(lRow, lCol) = arr(i, 1)
    
32.         temp(lRow, lCol + 1) = temp(lRow, lCol + 1) + arr(i, 12)
    
33.         temp(lRow, lCol + 2) = temp(lRow, lCol + 2) + arr(i, 13)
    
34.     Next
    
35.     Application.ScreenUpdating = False
    
36.    
    
37.     ActiveSheet.UsedRange.ClearContents
    
38.     Range("a4").Resize(UBound(arr), UBound(temp, 2)).Value = temp
    
39.     ReDim temp(1 To 2, 1 To dicName.Count * 3)
    
40.     arr2 = dicName.keys
    
41.     For i = 1 To dicName.Count
    
42.         temp(2, i * 3 - 2) = "日期"
    
43.         temp(2, i * 3 - 1) = "销售额"
    
44.         temp(2, i * 3) = "已收"
    
45.     Next
    
46.     lCol = 0
    
47.     For i = 2 To dicName.Count * 3 Step 3
    
48.         temp(1, i) = arr2(lCol)
    
49.         lCol = lCol + 1
    
50.     Next
    
51.     Range("a2").Resize(UBound(temp), UBound(temp, 2)).Value = temp
    
52.     Application.ScreenUpdating = True
    
53.     Set dicName = Nothing
    
54.     Set dic = Nothing
    
55.     MsgBox "统计完成"
    
56. End Sub

复制代码

用的字典装数组的方法，复杂了，如果同一个人没有日期重复的记录，代码可以更少。

hwc2ycy

1. Sub teset22()
   
2.     Dim arr, temp()
   
3.     Dim lRow As Long, lCol As Long
   
4.     Dim dicName As Object, dic As Object, icRow As Object
   
5.     Dim i As Long
   
6. 
   
7.     Set dic = CreateObject("scripting.dictionary")
   
8.     Set dicName = CreateObject("scripting.dictionary")
   
9.     Set dicRow = CreateObject("scripting.dictionary")
   
10. 
    
11.     arr = Sheets("sheet1").Range("a6:m" & Sheet1.[a65536].End(xlUp).Row)
    
12.     For i = 1 To UBound(arr, 1)
    
13. 
    
14.         If Not dicName.exists(arr(i, 2)) Then
    
15.             '数组扩容,3列一组
    
16.             ReDim Preserve temp(1 To UBound(arr), 1 To (dicName.Count + 1) * 3)
    
17.             dicName.Add arr(i, 2), dicName.Count + 1
    
18.             '列号
    
19.             dicRow.Add arr(i, 2), 1
    
20.         End If
    
21. 
    
22.         '对应姓名在哪一列
    
23.         lCol = dicName(arr(i, 2)) * 3 - 2
    
24.         '行号
    
25.         lRow = dicRow(arr(i, 2))
    
26.         temp(lRow, lCol) = arr(i, 1)
    
27.         temp(lRow, lCol + 1) = arr(i, 12)
    
28.         temp(lRow, lCol + 2) = arr(i, 13)
    
29.         dicRow(arr(i, 2)) = dicRow(arr(i, 2)) + 1
    
30.     Next
    
31.    
    
32.     Application.ScreenUpdating = False
    
33.    
    
34.     ActiveSheet.UsedRange.Offset(2).ClearContents
    
35.     Range("a4").Resize(UBound(arr), UBound(temp, 2)).Value = temp
    
36.     ReDim temp(1 To dicName.Count * 3)
    
37.     arr = dicName.keys
    
38.     For i = 0 To UBound(arr)
    
39.         temp(i * 3 + 2) = arr(i)
    
40.     Next
    
41.     Range("a2").Resize(, UBound(temp)).Value = temp
    
42.    
    
43.     Application.ScreenUpdating = True
    
44.     Set dicName = Nothing
    
45.     Set dic = Nothing
    
46.     Set dicRow = Nothing
    
47.    
    
48.     MsgBox "统计完成"
    
49. End Sub

复制代码

edwardk2

hwc2ycy 发表于 2013-12-11 19:03
用的字典装数组的方法，复杂了，如果同一个人没有日期重复的记录，代码可以更少。

大神膜拜！！太谢谢您了，厉害