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

nuation · 发表于 2012-5-26 00:18

本帖最后由 nuation 于 2012-5-26 03:09 编辑

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

桌面.rar (23.01 KB, 下载次数: 80)
菜鸟09年3月.XLS只是其中一个工作薄。。。还有很多个工薄（每个月一个表，格式一样，如还有“菜鸟09年4月”）所以希望写一个代码，就要工作薄所在的工作夹里面的工作薄汇总成效果汇总表一样的效果

该贴已经同步到 nuation的微博

KCFONG · 发表于 2012-5-26 00:46

see if help you

nuation · 发表于 2012-5-26 01:08

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

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

zhaogang1960 · 发表于 2012-5-26 01:11

短信收到，请测试

Sub Macro1()
Dim MyPath$, MyName$, arr, brr(1 To 100000, 1 To 6), MyDate As Date, i&, j&, m&
MyPath = ThisWorkbook.Path & ""
MyName = Dir(MyPath & "*.xls")
Application.ScreenUpdating = False
Do While MyName <> ""
If MyName <> ThisWorkbook.Name Then
a = Split(MyName, "年")
MyDate = 20 & Right(a(0), 2) & "-" & Split(a(1), "月")(0) & "-1"
With GetObject(MyPath & MyName)
arr = .Sheets(1).UsedRange
.Close False
End With
For i = 3 To UBound(arr)
For j = 2 To 37 Step 4
m = m + 1
brr(m, 1) = arr(i, 1)
brr(m, 2) = arr(1, j)
brr(m, 3) = arr(i, j)
brr(m, 4) = arr(i, j + 1)
brr(m, 5) = arr(i, j + 2)
brr(m, 6) = MyDate
Next
Next
End If
MyName = Dir
Loop
[a1].CurrentRegion.Offset(1).ClearContents
[a2].Resize(m, 6) = brr
Application.ScreenUpdating = True
End Sub

复制代码

zhaogang1960 · 发表于 2012-5-26 01:13

请看附件

桌面.rar (36.45 KB, 下载次数: 119)

nuation · 发表于 2012-5-26 01:31

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

nuation · 发表于 2012-5-26 01:35

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

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

zhaogang1960 · 发表于 2012-5-26 01:40

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)

opiona · 发表于 2012-5-26 01:45

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

复制代码

nuation · 发表于 2012-5-26 02:27

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

		自动登录	找回密码
密码			免费注册

[已解决] 快速按条件-跨工作薄汇总

评分

评分