Dim i As Long, n As Long, nn&, aa$, nm$, nm1$ Dim Sht1 As Worksheet, sh As Worksheet Application.ScreenUpdating = False Set Sht1 = ActiveSheet: nn = 5 Sht1.[b5:e27] = \
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)
nm1=split(mid(filename,instrrev(filename,\ 一句代码代替以下3句
‘aa = InStrRev(Filename, \
‘nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel文件名 ‘nm1 = Left(nm, Len(nm) - 4) '去除后缀的Excel文件名 If nm1 <> Sht1.Name Then
Workbooks.Open myfile(i) Dim wb As Workbook Set wb = ActiveWorkbook For Each sh In Sheets sh.Activate
ma = [b65536].End(xlUp).Row If ma > 6 Then ‘第6行是表头
If ma > 10 Then ma = 10 ‘只要取4行数据 For ii = 7 To ma
Sht1.Cells(nn, 2).Resize(1, 3) = Cells(ii, 2).Resize(1, 3).Value
Sht1.Cells(nn, 5) = Cells(ii, 6).Value nn = nn + 1 Next ii GoTo 100 Else
GoTo 100 End If
mc = [d65536].End(xlUp).Row
If mc > 7 Then ‘第7行是表头
If mc > 11 Then mc = 11 ‘只要取4行数据 For ii = 8 To mc
Sht1.Cells(nn, 2).Resize(1, 3) = Cells(ii, 4).Resize(1, 3).Value
Sht1.Cells(nn, 5) = Cells(ii, 8).Value nn = nn + 1 Next ii GoTo 100 Else
GoTo 100 End If 100:
Next sh
wb.Close savechanges:=False Set wb = Nothing End If Next Else
MsgBox \该文件夹里没有任何文件\ End If End With [a1].Select
Set myFs = Nothing
Application.ScreenUpdating = True End Sub
‘http://club.excelhome.net/viewthread.php?tid=462710&pid=3020658&page=1&extra=page=2
‘sum.xls
Sub pldrsj0724()
'批量导入指定文件的数据
Dim myFs As FileSearch, myfile, Myr1&, Arr Dim myPath$, Filename$, nm2$
Dim i&, j&, n&, nn&, aa$, nm$, nm1$ Dim Sht1 As Worksheet, sh As Worksheet Application.ScreenUpdating = False Set Sht1 = ActiveSheet
Myr1 = Sht1.[a65536].End(xlUp).Row Arr = Sht1.Range(\
Sht1.Range(\
nm2 = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) Set myFs = Application.FileSearch
myPath = ThisWorkbook.Path With myFs
.NewSearch
.LookIn = myPath
.FileType = msoFileTypeNoteItem .Filename = \
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, \
nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel文件名 nm1 = Left(nm, Len(nm) - 4) '去除后缀的Excel文件名 If nm1 <> nm2 Then
Workbooks.Open myfile(i) Dim wb As Workbook Set wb = ActiveWorkbook For Each sh In Sheets
For j = 1 To UBound(Arr) If sh.Name = Arr(j, 1) Then sh.Activate
Set r1 = Range(\ nn = r1.Row
Arr(j, 2) = Cells(nn, 9) GoTo 100 End If Next j Next sh 100:
wb.Close savechanges:=False Set wb = Nothing End If Next Else
MsgBox \该文件夹里没有任何文件\ End If End With Sht1.Select
[b3].Resize(UBound(Arr), 1) = Application.Index(Arr, 0, 2) Set myFs = Nothing
Application.ScreenUpdating = True End Sub
6，多工作表提取指定数据（数组）
‘http://excel.aa.topzj.com/viewthread.php?tid=399457&pid=73718&page=1&extra=#pid73718 Sub fpkf()
Application.ScreenUpdating = False Dim Myr&, Arr, yf, x&, Myr1&, r1 Dim Sht As Worksheet
Myr = Sheet1.[b65536].End(xlUp).Row Sheet1.Range(\Arr = Sheet1.Range(\[j8].Formula = \[j8].AutoFill Range(\
Range(\
For Each Sht In Sheets
If Sht.Name <> Sheet1.Name Then
yf = Left(Sht.Name, Len(Sht.Name) - 2) Sht.Activate
Myr1 = [a65536].End(xlUp).Row - 1 For x = 7 To Myr1
If Cells(x, 1) <> \
Set r1 = Sheet1.Range(\ If Not r1 Is Nothing Then
Arr(r1.Row - 7, yf) = Cells(x, \ End If End If Next x End If Next
Sheet1.Activate
[c8].Resize(UBound(Arr), UBound(Arr, 2)) = Arr [j:j].Clear
Application.ScreenUpdating = True End Sub
7，多工作簿多工作表查询汇总去重复值（字典数组）
‘http://club.excelhome.net/viewthread.php?tid=485193&pid=3181286&page=1&extra=page=1
‘详细记录.xls
‘3个工作簿需要都打开 Sub xxjl()
Dim Sht1 As Worksheet, Sht As Worksheet
Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook Dim i&, Myr2&, Arr2, Myr&, Arr, Myr1&, xm$, yl$ Application.ScreenUpdating = False Set wb1 = ActiveWorkbook
Set wb2 = Workbooks(\购进\Set wb3 = Workbooks(\配料\wb2.Activate
Myr2 = [a65536].End(xlUp).Row Arr2 = Range(\wb3.Activate
For i = 1 To UBound(Arr2) wb3.Activate xm = Arr2(i, 2)
For Each Sht In Sheets If Sht.Name = xm Then Sht.Activate
Myr = [a65536].End(xlUp).Row Arr = Range(\ For j = 1 To UBound(Arr) yl = Arr(j, 1) wb1.Activate
For Each Sht1 In Sheets If Sht1.Name = yl Then Sht1.Activate
Myr1 = [a65536].End(xlUp).Row + 1 Cells(Myr1, 1) = Arr2(i, 1) Cells(Myr1, 3) = Arr2(i, 3)
Cells(Myr1, 2) = Arr2(i, 4) * Arr(j, 2) Exit For End If Next Next j GoTo 100 End If Next