快速按条件-跨工作薄汇总

nuation

汇总表需要四列信息：自编码+品种 名称；经销商；数量；实洋；码洋；时间表
自编码+品种就是从源数据表的第一列数据， 经销商是打横着来的，所以表有八个经销商。。。就要复制八次整理，我有个效果图是复制了两个经销商的。可以参考下。
后面三列数据是经销商的数据。数量，实洋，码洋； 时间表是指源工作表的文件名，去掉菜鸟两个字后的名字 09年3月
桌面.rar (23.01 KB, 下载次数: 79)

2012-5-26 00:17 上传

点击文件名下载附件

菜鸟09年3月.XLS只是其中一个工作薄。。。还有很多个工薄（每个月一个表，格式一样，如还有“菜鸟09年4月”）所以希望写一个代码，就要工作薄所在的工作夹里面的工作薄汇总成效果汇总表一样的效果
该贴已经同步到 nuation的微博

KCFONG

see if help you

nuation

KCFONG 发表于 2012-5-26 00:46
see if help you

哗~ KCFONG。。。好久没见了。这个只是减少了八次复制粘贴。。同一个文件夹外面还有三十几个工作薄呢？ 这个做到初步结果了（另：合计不要相加） ，这部分，老大还要出手呀

zhaogang1960

短信收到，请测试

1. Sub Macro1()
   
2.     Dim MyPath$, MyName$, arr, brr(1 To 100000, 1 To 6), MyDate As Date, i&, j&, m&
   
3.     MyPath = ThisWorkbook.Path & ""
   
4.     MyName = Dir(MyPath & "*.xls")
   
5.     Application.ScreenUpdating = False
   
6.     Do While MyName <> ""
   
7.         If MyName <> ThisWorkbook.Name Then
   
8.             a = Split(MyName, "年")
   
9.             MyDate = 20 & Right(a(0), 2) & "-" & Split(a(1), "月")(0) & "-1"
   
10.             With GetObject(MyPath & MyName)
    
11.                 arr = .Sheets(1).UsedRange
    
12.                 .Close False
    
13.             End With
    
14.             For i = 3 To UBound(arr)
    
15.                 For j = 2 To 37 Step 4
    
16.                     m = m + 1
    
17.                     brr(m, 1) = arr(i, 1)
    
18.                     brr(m, 2) = arr(1, j)
    
19.                     brr(m, 3) = arr(i, j)
    
20.                     brr(m, 4) = arr(i, j + 1)
    
21.                     brr(m, 5) = arr(i, j + 2)
    
22.                     brr(m, 6) = MyDate
    
23.                 Next
    
24.             Next
    
25.         End If
    
26.         MyName = Dir
    
27.     Loop
    
28.     [a1].CurrentRegion.Offset(1).ClearContents
    
29.     [a2].Resize(m, 6) = brr
    
30.     Application.ScreenUpdating = True
    
31. End Sub
    
32. 
    

复制代码

zhaogang1960

请看附件
桌面.rar (36.45 KB, 下载次数: 119)

2012-5-26 01:13 上传

点击文件名下载附件

nuation

要加判断了~ 有些不能复制。。。经销商那里有些不是八个的就跳错，可否根据“数量合计”这个来判断复制多少行。

nuation

zhaogang1960 发表于 2012-5-26 01:13
请看附件

   brr(m, 2) = arr(1, j) 跳下标越界~~

zhaogang1960

nuation 发表于 2012-5-26 01:35
brr(m, 2) = arr(1, j) 跳下标越界~~

从第二列到倒数第四列：
For j = 2 To UBound(arr, 2) - 3 Step 4
桌面.rar (36.45 KB, 下载次数: 192)

2012-5-26 01:40 上传

点击文件名下载附件

opiona

1. '********************************************
   
2. '**********  北极狐工作室出品  **************
   
3. '**********  QQ：14885553      **************
   
4. '*** 新浪微博  http://weibo.com/1053147023 **
   
5. '********************************************
   
6. 
   
7. 
   
8. Sub Opiona()
   
9. Dim f
   
10. 'On Error Resume Next
    
11. Application.ScreenUpdating = False '关闭屏幕刷新
    
12. Application.DisplayAlerts = False '关闭提示
    
13. Dim SQL$, Cnn As Object
    
14. Set Cnn = CreateObject("Adodb.Connection")
    
15. t = Timer
    
16. s = "\*.xls"
    
17. Set SH1 = Sheets("Sheet1")
    
18. SH1.Range("A2:G65536").ClearContents  '清场
    
19. n = 0: SQL = ""
    
20. Dim Str经销商 As String
    
21. Dim Str时间 As String
    
22. Dim Str As String
    
23. f = Dir(ThisWorkbook.Path & s) '生成查找EXCEL的目录
    
24.     Do While f > ""   '在目录中循环
    
25.           If f <> ThisWorkbook.Name Then   '如果不是打开的工作簿
    
26.                   Set wb = Workbooks.Open(ThisWorkbook.Path & "" & f) '打开已经存在的EXCEL工件簿文件
    
27.                   Cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" & ThisWorkbook.Path & "" & f
    
28.                   
    
29.                   Str时间 = Mid(f, 3, Len(f) - 6)
    
30.                   SQL = ""
    
31.               For i = 0 To 8
    
32.                   Str经销商 = wb.Sheets("Sheet1").Cells(1, i * 4 + 2)
    
33.                   Str = ""
    
34.                   Str = Str & "F1 AS 名称,"
    
35.                   Str = Str & " '" & Str经销商 & "'" & " as 经销商,"
    
36.                   Str = Str & "F" & i * 4 + 2 & " AS 数量,"
    
37.                   Str = Str & "F" & i * 4 + 3 & " AS 实洋,"
    
38.                   Str = Str & "F" & i * 4 + 4 & " AS 码洋,"
    
39.                  ' Str = Str & "F" & i * 4 + 5 & " AS 折扣,"
    
40.                   Str = Str & " '" & Str时间 & "'" & " as 时间表 "
    
41.                   SQL = SQL & "select " & Str & "from [Sheet1$A3:AK2000] union all "
    
42.               Next i
    
43.               SQL = Mid(SQL, 1, Len(SQL) - 10)
    
44.               SQL = "select * from (" & SQL & ") where 名称<>'合计' and abs(数量)>0"
    
45.               r = SH1.Range("A65536").End(xlUp).Row + 1
    
46.               SH1.Range("A" & r).CopyFromRecordset Cnn.Execute(SQL)
    
47.               Cnn.Close
    
48.               wb.Close
    
49.           End If
    
50.           f = Dir
    
51.     Loop
    
52. 
    
53. Application.ScreenUpdating = True
    
54. Application.DisplayAlerts = True
    
55. MsgBox "用时：" & Format(Timer - t, "#0.0000") & " 秒", , "北极狐提示!!"
    
56. End Sub
    

复制代码

nuation

OK,谢谢老师们。。谢谢~