End If Next st
t = d.items
[f3].Resize(d.Count, 1) = Application.Transpose(t)
Exit Sub
For i = 3 To [b65536].End(3).Row
Cells(i, 6) = d(\ Next i End Sub
14，多工作簿汇总（FileSearch 和 Dir）
‘2010-5-5
‘汇总表.xls__解决一个月的汇总 Sub rmxb0505()
Dim myFs As FileSearch
Dim myPath As String, Filename$
Dim i&, n&, r%, Arr1(), rq, sl, rr, yy, Myc%
Dim Sht1 As Worksheet, sh As Worksheet, yg$, bb Dim aa, nm1$, m, arr, r1, j&, Rmx, Ymx, Rmxhj Dim js, ks, x, y, col%, nm$ Application.ScreenUpdating = False On Error Resume Next Set Sht1 = ActiveSheet
Myc = [iv2].End(xlToLeft).Column
Range(\Rmx = Range(\Sheet2.Activate
Ymx = Range(\Sht1.Activate
Set myFs = Application.FileSearch
myPath = ThisWorkbook.Path '& \发货工作量统计\\\ With myFs
.NewSearch
.LookIn = myPath
.FileType = msoFileTypeNoteItem .Filename = \
.SearchSubFolders = True
If .Execute(SortBy:=msoSortByFileName) > 0 Then n = .FoundFiles.Count
ReDim myfile(1 To n) As String For i = 1 To n
myfile(i) = .FoundFiles(i) Filename = myfile(i)
aa = InStrRev(Filename, \ yg = Left(Filename, aa - 1) bb = InStrRev(yg, \
yg = Right(yg, Len(yg) - bb) '员工姓名 nm = Right(Filename, Len(Filename) - aa) nm1 = Left(nm, Len(nm) - 4)
If nm1 <> \汇总表\ Workbooks.Open myfile(i) r = 0
Dim wb As Workbook Set wb = ActiveWorkbook Set sh = wb.Sheets(\ sh.Activate
bb = Left(nm1, Len(nm1) - 1) rq = Split(bb, \ '日期 rr = Val(Right(rq, 2)) '日
yy = Val(Left(rq, Len(rq) - 2)) '月 sl = Val(Split(bb, \ '订单数 Set r1 = Sht1.Rows(1).Find(yg, , , 1) If Not r1 Is Nothing Then col = r1.Column - 1
Rmx(rr, col) = Rmx(rr, col) + sl '订单总数 End If
m = sh.[a65536].End(xlUp).Row arr = Range(\ For j = 1 To UBound(arr)
If arr(j, 1) = \仓库配货单\ r = r + 1
ReDim Preserve Arr1(1 To r) Arr1(r) = j End If Next
For j = 1 To r
If j <> r Then
js = Arr1(j + 1) - 1 Else
js = m End If
ks = Arr1(j) + 3 For x = ks To js
If Trim(arr(x, 2)) = \
If InStr(arr(x, 2), \注意\订单明细\
0 Or InStr(arr(x, 2), \装箱单\ Else
Rmx(rr, col + 1) = Rmx(rr, col + 1) + 1 '配货明细 Rmx(rr, col + 2) = Rmx(rr, col + 2) + Val(arr(x, 8)) '配货量数
End If 100:
Next Next
wb.Close savechanges:=False Set wb = Nothing End If Next Else
MsgBox \该文件夹里没有任何文件\ End If End With
Set myFs = Nothing Sht1.Activate
[b3].Resize(31, UBound(Rmx, 2)) = Rmx If InStr(Sht1.Name, \月\
Sht1.Name = yy & \月\ End If [a1].Select
Rmxhj = Range(\
For i = 1 To 3 * UBound(Rmxhj, 2) / (Myc - 1) 'Step 3 Ymx(yy, 4 * i - 2) = Rmxhj(1, 3 * i - 2) Ymx(yy, 4 * i - 1) = Rmxhj(1, 3 * i - 1) Ymx(yy, 4 * i) = Rmxhj(1, 3 * i) Next
Sheet2.[b3].Resize(12, UBound(Ymx, 2)) = Ymx Application.ScreenUpdating = True End Sub
Sub rmxb0505a()
Dim myPath As String, Filename$, myXL Dim i&, n&, r%, Arr1(), rq, sl, rr, yy, Myc%
Dim Sht1 As Worksheet, sh As Worksheet, yg$, bb Dim aa, nm1$, m, arr, r1, j&, Rmx, Ymx, Rmxhj Dim js, ks, x, y, col%, arml
Application.ScreenUpdating = False On Error Resume Next Set Sht1 = ActiveSheet
Myc = [iv2].End(xlToLeft).Column arml = Range(\
Range(\Rmx = Range(\Sheet2.Activate
Ymx = Range(\Sht1.Activate
For y = 1 To UBound(arml, 2) Step 3 yg = arml(1, y)
myPath = ThisWorkbook.Path & \ Filename = Dir(myPath & \ Do While Filename <> \ aa = myPath & Filename
nm1 = Left(Filename, Len(Filename) - 4) bb = Left(nm1, Len(nm1) - 1) rq = Split(bb, \ '日期 rr = Val(Right(rq, 2)) '日
yy = Val(Left(rq, Len(rq) - 2)) '月
If nm1 <> \汇总表\ Workbooks.Open aa r = 0
Dim wb As Workbook Set wb = ActiveWorkbook Set sh = wb.Sheets(\ sh.Activate
sl = Val(Split(bb, \ '订单数 Set r1 = Sht1.Rows(1).Find(yg, , , 1) If Not r1 Is Nothing Then col = r1.Column - 1
Rmx(rr, col) = Rmx(rr, col) + sl '订单总数 End If
m = sh.[a65536].End(xlUp).Row arr = Range(\ For j = 1 To UBound(arr)
If arr(j, 1) = \仓库配货单\ r = r + 1
ReDim Preserve Arr1(1 To r) Arr1(r) = j End If Next
For j = 1 To r
If j <> r Then
js = Arr1(j + 1) - 1 Else
js = m End If
ks = Arr1(j) + 3 For x = ks To js
If Trim(arr(x, 2)) = \
If InStr(arr(x, 2), \注意\> 0 Or InStr(arr(x, 2), \订单明细\> 0 Or InStr(arr(x, 2), \装箱单\ Else
Rmx(rr, col + 1) = Rmx(rr, col + 1) + 1 '配货明细
Rmx(rr, col + 2) = Rmx(rr, col + 2) + Val(arr(x, 8)) End If 100:
Next Next
wb.Close savechanges:=False Set wb = Nothing End If
Filename = Dir Loop Next
Sht1.Activate
[b3].Resize(31, UBound(Rmx, 2)) = Rmx If InStr(Sht1.Name, \月\
Sht1.Name = yy & \月\ End If [a1].Select
Rmxhj = Range(\
For i = 1 To 3 * UBound(Rmxhj, 2) / (Myc - 1) Ymx(yy, 4 * i - 2) = Rmxhj(1, 3 * i - 2) Ymx(yy, 4 * i - 1) = Rmxhj(1, 3 * i - 1) Ymx(yy, 4 * i) = Rmxhj(1, 3 * i) Next
Sheet2.[b3].Resize(12, UBound(Ymx, 2)) = Ymx Application.ScreenUpdating = True End Sub
15，多工作簿汇总（FileSearch） by:Long III
Private Sub CommandButton1_Click()
Dim Twb As Workbook, Wb As Workbook Dim rng As Range
'配货量数