求助：用vba实现多表透视的效果

toadandswan

求助各位大侠，想要用vba实现 用sql多表透视的效果
透视效果 和要求都在附件中说明，望大侠们不惜赐教！
用VBA实现多表透视的效果.rar (9.97 KB, 下载次数: 8)

2015-4-26 23:23 上传

点击文件名下载附件

toadandswan

( ▼-▼ ) 又要沉了么

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   xm = [{"期初","入库","出库"}]
   
7.   With Worksheets("结存")
   
8.     rq1 = .Range("b1")
   
9.     rq2 = .Range("d1")
   
10.   End With
    
11.   For k = 1 To UBound(xm)
    
12.     With Worksheets(xm(k))
    
13.       r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
14.       arr = .Range("a2:d" & r)
    
15.       For i = 1 To UBound(arr)
    
16.         If arr(i, 1) >= rq1 And arr(i, 1) <= rq2 Then
    
17.           If Not d.exists(arr(i, 2)) Then
    
18.             ReDim brr(1 To 6)
    
19.             brr(1) = arr(i, 2)
    
20.             brr(2) = arr(i, 3)
    
21.           Else
    
22.             brr = d(arr(i, 2))
    
23.           End If
    
24.           brr(k + 2) = brr(k + 2) + arr(i, 4)
    
25.           d(arr(i, 2)) = brr
    
26.         End If
    
27.       Next
    
28.     End With
    
29.   Next
    
30.   brr = Application.Transpose(Application.Transpose(d.items))
    
31.   ReDim crr(1 To UBound(brr, 2))
    
32.   crr(1) = "总计"
    
33.   For i = 1 To UBound(brr)
    
34.     brr(i, 6) = brr(i, 3) + brr(i, 4) - brr(i, 5)
    
35.     For j = 3 To UBound(brr, 2)
    
36.       crr(j) = crr(j) + brr(i, j)
    
37.     Next
    
38.   Next
    
39.   With Worksheets("结存")
    
40.     .UsedRange.Offset(3, 0).ClearContents
    
41.     .Range("a4").Resize(UBound(brr), UBound(brr, 2)) = brr
    
42.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
43.     Range("a" & r + 1).Resize(1, UBound(crr)) = crr
    
44.   End With
    
45. End Sub
    

复制代码

chxw68

详见附件。

toadandswan

chxw68 发表于 2015-4-27 10:55
详见附件。

非常感谢 chxw68 老师的解答，操作了下可以达到要求，但是还有个小问题就是 筛选日期为同一天的时候 会提示下表越界

笑看123

chxw68 发表于 2015-4-27 10:55
详见附件。

老师，
冒昧的麻烦您了，还可以帮我一个大忙吗.......1、点击按钮时   选择文件夹
2、自动统计被选择文件夹下的文件（包括子文件夹）    不需要子文件夹名称，全部word的内容就行了！  


这个附件代码有点小问题，可以帮我改一下吗
[url=]大众 TSI - 副本v1.zip[/url]

chxw68

1. Sub test11()
   
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 Worksheets("结存")
   
8.     rq1 = .Range("b1")
   
9.     rq2 = .Range("d1")
   
10.   End With
    
11.   With cnn
    
12.     If Application.Version = "11.0" Then
    
13.       .Provider = "microsoft.jet.oledb.4.0"
    
14.       .ConnectionString = "extended properties=""excel 8.0;HDR=YES;"";data source=" & mybook
    
15.     Else
    
16.       .Provider = "microsoft.ACE.oledb.12.0"
    
17.       .ConnectionString = "extended properties=""excel 12.0;HDR=YES;"";data source=" & mybook
    
18.     End If
    
19.     .Open
    
20.   End With
    
21.   sql1 = "select 编码,名称,sum(数量) as 数量 from [期初$a1:d] where 日期 between #" & rq1 & "# and #" & rq2 & "# group by 编码,名称"
    
22.   sql2 = "select 编码,名称,sum(数量) as 数量 from [入库$a1:d] where 日期 between #" & rq1 & "# and #" & rq2 & "# group by 编码,名称"
    
23.   sql3 = "select 编码,名称,sum(数量) as 数量 from [出库$a1:d] where 日期 between #" & rq1 & "# and #" & rq2 & "# group by 编码,名称"
    
24.   sql = "select a.编码,a.名称,a.数量 as 期初数量,b.数量 as 入库数量,c.数量 as 出库数量,a.数量+b.数量-c.数量 as 结存数量 from ((" & sql1 & ") a left outer join (" & sql2 & ") b on a.编码=b.编码) left outer join (" & sql3 & ") c on a.编码=c.编码"
    
25.   rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
    
26.   With Worksheets("结存")
    
27.     .UsedRange.Offset(3, 0).Delete
    
28.     .Range("a4").CopyFromRecordset rs
    
29.     r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    
30.     .Cells(r, 1) = "合计"
    
31.     .Cells(r, 3).Resize(1, 4).FormulaR1C1 = "=SUM(R[" & 4 - r & "]C:R[-1]C)"
    
32.   End With
    
33. End Sub
    

复制代码

chxw68

提供了字典和ADO两种方法。

toadandswan

chxw68 发表于 2015-4-27 11:20
提供了字典和ADO两种方法。

非常感谢老师的解答..