Excel VBA_多工作簿多工作表汇总实例集锦(3)

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

百度搜索“77cn”或“免费范文网”即可找到本站免费阅读全部范文。收藏本站方便下次阅读，免费范文网，提供经典小说综合文库Excel VBA_多工作簿多工作表汇总实例集锦(3)在线全文阅读。