续查询使用 100:
Next Next
MsgBox \End Sub
'调用XLM4.0宏表函数读取指定区域的内容 '如果指定工作表不存在，返回错误
Public Function GetCellValue(sPath, sFile, sSheet, sCell)
GetCellValue = ExecuteExcel4Macro(\& sPath & \& sFile & \_
& sSheet & \End Function
‘2011-10-17
‘http://club.excelhome.net/thread-775193-1-1.html
‘只适用于2003版本
Sub GetData()
Dim sFullName, sFile, sPath, sSheet, sCell As String Dim sResult As String
Dim i&, Myr&, Myc%, Arr, ad On Error Resume Next
Application.ScreenUpdating = False
ad = Array(\\\\\\\要提取单元格的绝对地址，可扩充
sPath = ThisWorkbook.Path & \文件路径赋值 Sheet1.Activate
Arr = [a1].CurrentRegion For r = 2 To UBound(Arr)
sFile = Arr(r, 1) & \文件名称赋值 sFullName = Dir(sPath & sFile)
If sFullName = \如果放弃选择文件，退出程序
sSheet = \指定工作表，即在数据源文件中要读取数据的Sheet的名称
For c = 0 To UBound(ad)
sCell = ad(c) '定义需要读取的单元格
sResult = GetCellValue(sPath, sFile, sSheet, sCell) If Err.Number <> 0 Then '找不到指定工作表（比如选错了文件）时进行提示
MsgBox \工作表 \不存在。请确保您选择了正确的文件，且源文件中工作表名称没有被修改。 \
Err.Clear
Exit Sub End If
Cells(r, c + 2) = sResult '把读取的数据写入当前文件 Next Next
MsgBox \
Application.ScreenUpdating = True End Sub
'调用XLM4.0宏表函数读取指定区域的内容 '如果指定工作表不存在，返回错误
Public Function GetCellValue(sPath, sFile, sSheet, sCell)
GetCellValue = ExecuteExcel4Macro(\& sPath & \& sFile & \
& sSheet & \End Function
22，用FSO取得文件名，宏函数统计指定单元格值
‘2011-11-4
‘http://club.excelhome.net/thread-784939-1-1.html Public Arr1() Sub Getfiles()
Dim Fso As Object, Fc, f1, myPath$, r% myPath = ThisWorkbook.Path '
Set Fso = CreateObject(\ Set f = Fso.GetFolder(myPath) Set Fc = f.Files For Each f1 In Fc
If InStr(f1.Name, \表1.xls\ r = r + 1
ReDim Preserve Arr1(1 To r) Arr1(r) = f1.Name End If Next End Sub
Sub GetData()
Dim sFullName$, sFile$, sPath$, sSheet$, sCell$ Dim sResult, ad$, r% On Error Resume Next
Application.ScreenUpdating = False Call Getfiles
ad = \
sPath = ThisWorkbook.Path & \文件路径赋值 Sheet1.Activate
For r = 1 To UBound(Arr1)
sFile = Arr1(r) '& \文件名称赋值 sFullName = Dir(sPath & sFile)
If sFullName = \如果放弃选择文件，退出程序
sSheet = \指定工作表，即在数据源文件中要读取数据的Sheet的名称
sCell = ad '定义需要读取的单元格
sResult = GetCellValue(sPath, sFile, sSheet, sCell) If Err.Number <> 0 Then '找不到指定工作表（比如选错了文件）时进行提示
MsgBox \工作表 \不存在。请确保您选择了正确的文件，且源文件中工作表名称没有被修改。 \
Err.Clear Exit Sub End If
[b1] = [b1] + sResult '把读取的数据写入当前文件 Next
MsgBox \Application.ScreenUpdating = True End Sub
'调用XLM4.0宏表函数读取指定区域的内容 '如果指定工作表不存在，返回错误
Public Function GetCellValue(sPath, sFile, sSheet, sCell)
GetCellValue = ExecuteExcel4Macro(\& sPath & \& sFile & \
& sSheet & \End Function
23，多工作簿汇总（Do While+字典）
‘http://club.excelhome.net/viewthread.php?tid=740844&pid=5036586&page=2&extra= ‘预算对比.xls Sub hz()
Dim Sht As Worksheet, col%, k1, t1
Dim i&, Myr&, j&, ii&, Arr, r%, Arr1(), Brr Dim d, k, t
Dim wb As Workbook, nm$ Dim sh As Worksheet Dim PATH As String Dim dirr
Set d = CreateObject(\
bt = Array(\实际数\\预算数\\实际与预算对比\\超支说明\\是否有提交申请报告（超支流程流水号）\
nm = \经营分析表汇总\PATH = ThisWorkbook.PATH dirr = Dir(PATH & \ Do While dirr <> \
If dirr <> ThisWorkbook.Name Then With GetObject(PATH & \ Set wb = Workbooks(dirr) Set sh = wb.Sheets(nm) For Each Sht In wb.Sheets
If InStr(Sht.Name, \店\ r = r + 1
ReDim Preserve Arr1(1 To r) Arr1(r) = Sht.Name
Myr = Sht.[b65536].End(xlUp).Row - 1 Arr = Sht.Range(\ For i = 1 To UBound(Arr) If Arr(i, 2) <> \ d(Arr(i, 2)) = \ End If Next End If Next
k = d.keys t = d.items
ReDim Brr(1 To d.Count, 1 To 5 * r) d.RemoveAll
For Each Sht In wb.Sheets
If InStr(Sht.Name, \店\ col = col + 1
Myr = Sht.[b65536].End(xlUp).Row Arr = Sht.Range(\ For i = 1 To UBound(Arr) If Arr(i, 2) <> \
d(Arr(i, 2)) = Arr(i, 3) & \6)
End If Next
k1 = d.keys t1 = d.items d.RemoveAll
For j = 0 To UBound(k1) For ii = 0 To UBound(k) If k1(j) = k(ii) Then
Brr(ii + 1, 5 * col - 4) = Split(t1(j), \ Brr(ii + 1, 5 * col - 3) = Split(t1(j), \
Brr(ii + 1, 5 * col - 2) = Split(t1(j), \For
End If Next Next End If Next
wb.Close False End With End If dirr = Dir Loop
[a4:iv1000].ClearContents
[a4:iv1000].Borders.LineStyle = xlNone [b2:iv3].ClearContents
[a4].Resize(UBound(k) + 1, 1) = Application.Transpose(k) For i = 1 To r
Cells(2, 5 * i - 3) = Arr1(i)
Cells(2, 5 * i - 3).Resize(1, 5).Merge Cells(3, 5 * i - 3).Resize(1, 5) = bt Next
[b4].Resize(UBound(Brr), 5 * r) = Brr
[a4].Resize(UBound(Brr), 5 * r + 1).Borders.LineStyle = 1
End Sub
‘http://club.excelhome.net/viewthread.php?tid=750050&pid=5094852&page=1&extra=page=1
Sub zdgx()
Dim Arr, myPath$, myName$, sh As Worksheet Dim m&, funm$, n&, Sht As Worksheet Dim d, k, t, Brr
Set d = CreateObject(\ Application.ScreenUpdating = False funm = \汇总表.xls\