不用透视表,求用字典解决

随风入夜2012

见到各位高手的代码写得出神入化,本人也看了许多精典帖子,虽然有所进步,但在实际工作中还是感到棘手.

想不用数据透视表(有时也不是那么方便),但要能达到我附件那样的效果,还望老师们赐教,先谢谢啦!

feiren228

关注！！！！！

chxw68

1. Sub test()
   
2.   Dim d As New Dictionary
   
3.   Dim d1 As New Dictionary
   
4.   Dim r%, i%
   
5.   Dim arr, brr()
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:d" & r)
   
9.     m = 1
   
10.     For i = 1 To UBound(arr)
    
11.       If Not d.Exists(arr(i, 1)) Then
    
12.         Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
13.       End If
    
14.       If Not d1.Exists(arr(i, 2)) Then
    
15.         m = m + 1
    
16.         d1(arr(i, 2)) = m
    
17.       End If
    
18.       If Not d(arr(i, 1)).Exists(arr(i, 3)) Then
    
19.         ReDim brr(1 To 6)
    
20.         brr(1) = arr(i, 3)
    
21.       Else
    
22.         brr = d(arr(i, 1))(arr(i, 3))
    
23.       End If
    
24.       brr(d1(arr(i, 2))) = brr(d1(arr(i, 2))) + arr(i, 4)
    
25.       brr(6) = brr(6) + arr(i, 4)
    
26.       d(arr(i, 1))(arr(i, 3)) = brr
    
27.     Next
    
28.   End With
    
29.   With Worksheets("sheet2")
    
30.     .Cells.Clear
    
31.     s = ""
    
32.     .Cells(1, 1) = "仓库"
    
33.     .Cells(1, 2) = "货号"
    
34.     .Cells(1, 7) = "总计"
    
35.     .Cells(1, 3).Resize(1, d1.Count) = d1.Keys
    
36.     For Each aa In d.Keys
    
37.       brr = Application.Transpose(Application.Transpose(d(aa).Items))
    
38.       r = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
    
39.       .Cells(r, 2).Resize(UBound(brr), UBound(brr, 2)) = brr
    
40.       r1 = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
    
41.       .Cells(r1, 2) = "汇总"
    
42.       With .Cells(r, 1)
    
43.         .Value = aa
    
44.         .Resize(r1 - r + 1, 1).Merge
    
45.       End With
    
46.       .Cells(r1, 3).Resize(1, UBound(brr, 2) - 1).FormulaR1C1 = "=SUM(R[" & r - r1 & "]C:R[-1]C)"
    
47.       s = s & "+R" & r1 & "C"
    
48.     Next
    
49.     r = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
    
50.     .Cells(r, 1) = "总计"
    
51.     .Cells(r, 3).Resize(1, UBound(brr, 2) - 1).FormulaR1C1 = "=" & Mid(s, 2)
    
52.     .Range("a1:g" & r).Borders.LineStyle = xlContinuous
    
53.   End With
    
54. End Sub
    

复制代码

chxw68

详见附件。

yjh_27

按照3级汇总,然后写进批注
http://club.excelhome.net/thread-1109540-1-1.html

chxw68

1. Sub test()
   
2.   Dim cnn As New ADODB.Connection
   
3.   Dim rs As New ADODB.Recordset
   
4.   Dim sql As String
   
5.   Dim mybook As String
   
6.   mybook = ThisWorkbook.FullName
   
7.   With cnn
   
8.     If Application.Version = "11.0" Then
   
9.       .Provider = "microsoft.jet.oledb.4.0"
   
10.       .ConnectionString = "extended properties=""excel 8.0;HDR=YES;"";data source=" & mybook
    
11.     Else
    
12.       .Provider = "microsoft.ACE.oledb.12.0"
    
13.       .ConnectionString = "extended properties=""excel 12.0;HDR=YES;"";data source=" & mybook
    
14.     End If
    
15.     .Open
    
16.   End With
    
17.   sql = "transform sum(数量) as 数量 select 仓库,货号 from [sheet1$a1:d] group by 仓库,货号 pivot 仓位"
    
18.   rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
    
19.   With Worksheets("sheet2")
    
20.     .Cells.Delete
    
21.     For j = 0 To rs.Fields.Count - 1
    
22.       .Cells(1, j + 1) = rs.Fields(j).Name
    
23.     Next
    
24.     .Range("a2").CopyFromRecordset rs
    
25.   End With
    
26. End Sub
    

复制代码

chxw68

用ADO也能实现。合计和格式没有设置。

chxw68

修改了一下，增加了列之间的合计。

chxw68

增加了合计项。

随风入夜2012

chxw68 发表于 2014-12-19 09:10
增加了合计项。

谢谢老师的解答
经测试若增加一个仓库后test1运行到
.Cells(r, 2).Resize(UBound(brr), UBound(brr, 2)) = brr
提示下标越界