[已解决]一个关于用VBA来统计的问题

夏之恋之夏

1.rar (188.5 KB, 下载次数: 29)

2012-11-20 15:09 上传

点击文件名下载附件
有1张数据表和几张需要统计的工作薄，需要用VBA来实现每个工作薄中的商品代码、商品名称，日期和数量（需要有商品数量的日期的列，没商品数量日期的列不需要显示），请高手帮忙，谢谢！

最佳答案

月排行榜 / 总排行榜

蓝桥玄霜

2012-11-21 10:14

是因为有数据的列超过了256了。
如果你有07版本的，可用以下代码：

1. Sub lqxs()
   
2. Dim Arr, i&, x$, x1$, d1, d2, j&, aa, Brr, ii&, m&
   
3. Dim d, k, t, d3, t3
   
4. Dim Sht As Worksheet, Sht1 As Worksheet
   
5.     Application.DisplayAlerts = False
   
6. Set d = CreateObject("Scripting.Dictionary")
   
7. Set d1 = CreateObject("Scripting.Dictionary")
   
8. Set d2 = CreateObject("Scripting.Dictionary")
   
9. Set d3 = CreateObject("Scripting.Dictionary")
   
10. Sheet1.Activate
    
11. For Each Sht In Sheets
    
12.     If Sht.Name <> "数据库" Then Sht.Delete
    
13. Next Sht
    
14. Call px
    
15. Arr = Sheet1.[a1].CurrentRegion
    
16. For i = 2 To UBound(Arr) - 1
    
17.     x1 = Arr(i, 1) & "-" & Arr(i, 2) & "|" & Arr(i, 4) & "," & Arr(i, 6) & "," & Arr(i, 7)
    
18.     d1(x1) = d1(x1) + Arr(i, 8) '数量
    
19.     x = Arr(i, 4)
    
20.     If InStr(d2(x), Arr(i, 1) & "-" & Arr(i, 2)) = 0 Then
    
21.     d2(x) = d2(x) & Arr(i, 1) & "-" & Arr(i, 2) & "|"  '日期
    
22.     End If
    
23.     If InStr(d(x), Arr(i, 6) & "," & Arr(i, 7)) = 0 Then
    
24.     d(x) = d(x) & Arr(i, 6) & "," & Arr(i, 7) & "|"  '商品名称
    
25.     End If
    
26.     d3(x) = Arr(i, 5)  '客户
    
27. Next
    
28. k = d.keys
    
29. t = d.items:  t3 = d3.items
    
30. For i = 0 To UBound(k)
    
31.     t(i) = Left(t(i), Len(t(i)) - 1)
    
32.     Sheets.Add after:=Sheets(Sheets.Count)
    
33.     Set Sht1 = ActiveSheet
    
34.     Sht1.Cells.Font.Size = 10
    
35.     Sht1.Name = t3(i)
    
36.     Sht1.[a1] = "客户：" & t3(i)
    
37.     Sht1.[a3] = "商品代码": Sht1.[b3] = "商品名称"
    
38.     If InStr(t(i), "|") Then
    
39.         aa = Split(t(i), "|")
    
40.         For j = 0 To UBound(aa)
    
41.             Sht1.Cells(j + 4, 1) = aa(j)
    
42.         Next
    
43.         Sht1.Cells(j + 4, 1) = "总计": m = j + 4
    
44.     Else
    
45.     End If
    
46.     t2 = d2(k(i))
    
47.     t2 = Left(t2, Len(t2) - 1)
    
48.     If InStr(t2, "|") Then
    
49.         aa = Split(t2, "|")
    
50.         For j = 0 To UBound(aa)
    
51.             Sht1.Cells(3, j + 3) = aa(j)
    
52.         Next
    
53.     End If
    
54.     Brr = Sht1.[a3].CurrentRegion
    
55.     For ii = 2 To UBound(Brr) - 1
    
56.         For j = 3 To UBound(Brr, 2)
    
57.             x1 = Brr(1, j) & "|" & k(i) & "," & Brr(ii, 1)
    
58.             If d1.exists(x1) Then Brr(ii, j) = d1(x1)
    
59.         Next
    
60.     Next
    
61.     Sht1.[a3].CurrentRegion = Brr
    
62.     Sht1.[a4].Resize(UBound(aa) + 1).TextToColumns Comma:=True
    
63.     Sht1.[a3].CurrentRegion.Borders.LineStyle = 1
    
64.     Sht1.Cells(m, 3).Formula = "=sum(r4c:r[-1]c)"
    
65.     Sht1.Cells(m, 3).AutoFill Sht1.Cells(m, 3).Resize(1, UBound(Brr, 2) - 2)
    
66. Next
    
67.     Application.DisplayAlerts = True
    
68. End Sub
    
69. 
    
70. 
    
71. Sub px()
    
72. Dim Myr&
    
73. Sheet1.Activate
    
74. Myr = [a65536].End(xlUp).Row
    
75. Range("A2").Select
    
76.     ActiveWorkbook.Worksheets("数据库").AutoFilter.Sort.SortFields.Clear
    
77.     ActiveWorkbook.Worksheets("数据库").AutoFilter.Sort.SortFields.Add Key:=Range( _
    
78.         "A2:A" & Myr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    
79.         xlSortTextAsNumbers
    
80.     ActiveWorkbook.Worksheets("数据库").AutoFilter.Sort.SortFields.Add Key:=Range( _
    
81.         "B2:B" & Myr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    
82.         xlSortTextAsNumbers
    
83.     With ActiveWorkbook.Worksheets("数据库").AutoFilter.Sort
    
84.         .Header = xlYes
    
85.         .MatchCase = False
    
86.         .Orientation = xlTopToBottom
    
87.         .SortMethod = xlPinYin
    
88.         .Apply
    
89.     End With
    
90. End Sub
    

复制代码

跳转到最佳答案楼层

夏之恋之夏

谁能帮我解决吗？是不是发错版块了呢！

上清宫主

可以说详细点吗？

夏之恋之夏

就是需要用VBA代码把第4至26行的数据都从第一张数据库中提取出来，其中包括商品代码、商品名称，日期和数量（需要有商品数量的日期的列，没商品数量日期的列不需要显示）如1月1日至1月9日之间没有这些商品名称的数量就不需要显示出来了。

蓝桥玄霜

日期太多，大于256了，需要用07版本了。

夏之恋之夏

就是因为日期超过了255列，所以想把没有数据的列不显示出来！这样就够了！

无聊的疯子

夏之恋之夏 发表于 2012-11-20 21:18
就是因为日期超过了255列，所以想把没有数据的列不显示出来！这样就够了！

一年365天，你能保证能有100多天没有数据？？
可以考虑分月显示或者分季度显示，这样比较好吧？

拖动滚动条和选择月分重新显示没多大区别嘛

蓝桥玄霜

是因为有数据的列超过了256了。
如果你有07版本的，可用以下代码：

1. Sub lqxs()
   
2. Dim Arr, i&, x$, x1$, d1, d2, j&, aa, Brr, ii&, m&
   
3. Dim d, k, t, d3, t3
   
4. Dim Sht As Worksheet, Sht1 As Worksheet
   
5.     Application.DisplayAlerts = False
   
6. Set d = CreateObject("Scripting.Dictionary")
   
7. Set d1 = CreateObject("Scripting.Dictionary")
   
8. Set d2 = CreateObject("Scripting.Dictionary")
   
9. Set d3 = CreateObject("Scripting.Dictionary")
   
10. Sheet1.Activate
    
11. For Each Sht In Sheets
    
12.     If Sht.Name <> "数据库" Then Sht.Delete
    
13. Next Sht
    
14. Call px
    
15. Arr = Sheet1.[a1].CurrentRegion
    
16. For i = 2 To UBound(Arr) - 1
    
17.     x1 = Arr(i, 1) & "-" & Arr(i, 2) & "|" & Arr(i, 4) & "," & Arr(i, 6) & "," & Arr(i, 7)
    
18.     d1(x1) = d1(x1) + Arr(i, 8) '数量
    
19.     x = Arr(i, 4)
    
20.     If InStr(d2(x), Arr(i, 1) & "-" & Arr(i, 2)) = 0 Then
    
21.     d2(x) = d2(x) & Arr(i, 1) & "-" & Arr(i, 2) & "|"  '日期
    
22.     End If
    
23.     If InStr(d(x), Arr(i, 6) & "," & Arr(i, 7)) = 0 Then
    
24.     d(x) = d(x) & Arr(i, 6) & "," & Arr(i, 7) & "|"  '商品名称
    
25.     End If
    
26.     d3(x) = Arr(i, 5)  '客户
    
27. Next
    
28. k = d.keys
    
29. t = d.items:  t3 = d3.items
    
30. For i = 0 To UBound(k)
    
31.     t(i) = Left(t(i), Len(t(i)) - 1)
    
32.     Sheets.Add after:=Sheets(Sheets.Count)
    
33.     Set Sht1 = ActiveSheet
    
34.     Sht1.Cells.Font.Size = 10
    
35.     Sht1.Name = t3(i)
    
36.     Sht1.[a1] = "客户：" & t3(i)
    
37.     Sht1.[a3] = "商品代码": Sht1.[b3] = "商品名称"
    
38.     If InStr(t(i), "|") Then
    
39.         aa = Split(t(i), "|")
    
40.         For j = 0 To UBound(aa)
    
41.             Sht1.Cells(j + 4, 1) = aa(j)
    
42.         Next
    
43.         Sht1.Cells(j + 4, 1) = "总计": m = j + 4
    
44.     Else
    
45.     End If
    
46.     t2 = d2(k(i))
    
47.     t2 = Left(t2, Len(t2) - 1)
    
48.     If InStr(t2, "|") Then
    
49.         aa = Split(t2, "|")
    
50.         For j = 0 To UBound(aa)
    
51.             Sht1.Cells(3, j + 3) = aa(j)
    
52.         Next
    
53.     End If
    
54.     Brr = Sht1.[a3].CurrentRegion
    
55.     For ii = 2 To UBound(Brr) - 1
    
56.         For j = 3 To UBound(Brr, 2)
    
57.             x1 = Brr(1, j) & "|" & k(i) & "," & Brr(ii, 1)
    
58.             If d1.exists(x1) Then Brr(ii, j) = d1(x1)
    
59.         Next
    
60.     Next
    
61.     Sht1.[a3].CurrentRegion = Brr
    
62.     Sht1.[a4].Resize(UBound(aa) + 1).TextToColumns Comma:=True
    
63.     Sht1.[a3].CurrentRegion.Borders.LineStyle = 1
    
64.     Sht1.Cells(m, 3).Formula = "=sum(r4c:r[-1]c)"
    
65.     Sht1.Cells(m, 3).AutoFill Sht1.Cells(m, 3).Resize(1, UBound(Brr, 2) - 2)
    
66. Next
    
67.     Application.DisplayAlerts = True
    
68. End Sub
    
69. 
    
70. 
    
71. Sub px()
    
72. Dim Myr&
    
73. Sheet1.Activate
    
74. Myr = [a65536].End(xlUp).Row
    
75. Range("A2").Select
    
76.     ActiveWorkbook.Worksheets("数据库").AutoFilter.Sort.SortFields.Clear
    
77.     ActiveWorkbook.Worksheets("数据库").AutoFilter.Sort.SortFields.Add Key:=Range( _
    
78.         "A2:A" & Myr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    
79.         xlSortTextAsNumbers
    
80.     ActiveWorkbook.Worksheets("数据库").AutoFilter.Sort.SortFields.Add Key:=Range( _
    
81.         "B2:B" & Myr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    
82.         xlSortTextAsNumbers
    
83.     With ActiveWorkbook.Worksheets("数据库").AutoFilter.Sort
    
84.         .Header = xlYes
    
85.         .MatchCase = False
    
86.         .Orientation = xlTopToBottom
    
87.         .SortMethod = xlPinYin
    
88.         .Apply
    
89.     End With
    
90. End Sub
    

复制代码