strTmp = GetFileFolderList(SubFolder) Next End If
GetFileFolderList = strTmp End Function
Sub EnumFolderInfo()
Dim fso, folder, myPath$ r = 0
myPath = ThisWorkbook.Path & \
Set fso = CreateObject(\ Set folder = fso.GetFolder(myPath) strTmp = GetFileFolderList(folder) Sheet3.[m:m].Clear
Sheet3.[m1].Resize(r, 1) = Application.Transpose(Arr1) End Sub
‘http://www.ozgrid.com/forum/showthread.php?t=71409 Sub testit()
Dim myPath$,mvvar,i&
myPath = ThisWorkbook.Path & \mvvar = FileList(myPath)
If TypeName(mvvar) <> \
For i = LBound(mvvar) To UBound(mvvar) Debug.Print mvvar(i) Next Else
MsgBox \ found\End If End Sub
返回指定路径下指定后缀所有的文件，返回一维数组。（不能得到子文件夹的文件） Function FileList(fldr, Optional fltr As String = \ Dim sTemp As String, sHldr As String
If Right$(fldr, 1) <> \ sTemp = Dir(fldr & fltr) If sTemp = \ FileList = False Exit Function End If Do
sHldr = Dir
If sHldr = \
sTemp = sTemp & \ Loop
FileList = Split(sTemp, \End Function
‘F:\\新发帖\\VBA\\星河\\郭绮华\\汇总表.xls 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), \注意\订单明细\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
21，不打开工作簿提取指定数据（宏函数）
‘不打开文件读取其他Excel文件的数据.xls Public Sub GetData()
Dim sFullName, sFile, sPath, sSheet, sCell As String Dim sResult As String
sFullName = Application.GetOpenFilename '读取数据源文件路径和名称 If sFullName = False Then Exit Sub '如果放弃选择文件，退出程序 Range(\Range(\Range(\
Range(\利用通配符*替换路径为空，提取文件名称
Range(\what:=Range(\replacement:=\ '替换上面提出的文件名称为空，提取文件路径
sFile = Range(\ '文件名称赋值 sPath = Range(\ '文件路径赋值 Range(\
sSheet = \ '指定工作表，即在数据源文件中要读取数据的Sheet的名称 On Error Resume Next
For r = 1 To 100 '100行数据
For c = 2 To 11 '10列数据，本例对应B:K列
sCell = Cells(r, c).Address '定义需要读取的区域，本例为B1:K100 sResult = GetCellValue(sPath, sFile, sSheet, sCell)
If Err.Number <> 0 Then '找不到指定工作表（比如选错了文件）时进行提示
MsgBox \工作表 \不存在。请确保您选择了正确的文件，且源文件中工作表名称没有被修改。 \
Err.Clear Exit Sub End If
Cells(r, c) = sResult '把读取的数据写入当前文件的B1:K100区域,便于后续查询使用
Next
Next
MsgBox \End Sub
'调用XLM4.0宏表函数读取指定区域的内容 '如果指定工作表不存在，返回错误
Public Function GetCellValue(sPath, sFile, sSheet, sCell)
GetCellValue = ExecuteExcel4Macro(\ & sSheet & \End Function
‘http://club.excelhome.net/viewthread.php?tid=725789&page=1#pid4926943 ‘2011-6-1 Bom总表.rar 放在总表的代码里：
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub
If Target.Address <> \nm = Target.Value
[c4:c45] = \Call GetData End Sub
以下代码放在模块1里面： Public nm$ Sub GetData()
Dim sFullName, sFile, sPath, sSheet, sCell As String Dim sResult As String
sFile = nm & \文件名称赋值
sPath = ThisWorkbook.Path & \文件路径赋值 sFullName = Dir(sPath & sFile)
If sFullName = \如果放弃选择文件，退出程序
sSheet = \指定工作表，即在数据源文件中要读取数据的Sheet的名称 On Error Resume Next For r = 4 To 45 For c = 3 To 6
If c = 4 Then GoTo 100
sCell = Cells(r, c).Address '定义需要读取的区域，本例为B4:f45 sResult = GetCellValue(sPath, sFile, sSheet, sCell)
If Err.Number <> 0 Then '找不到指定工作表（比如选错了文件）时进行提示 MsgBox \工作表 \不存在。请确保您选择了正确的文件，且源文件中工作表名称没有被修改。 \ Err.Clear Exit Sub End If
Cells(r, c) = sResult '把读取的数据写入当前文件的B4:f45区域,便于后