Excel VBA_多工作簿多工作表汇总情况实例集锦(2)

If myr2 < 9 Then

Cells(9, 1).Resize(1, 2) = Array("PartNo.", "TTL Qty")

Cells(10, 1).Resize(UBound(k) + 1, 1) = Application.Transpose(k)

Cells(10, 2).Resize(UBound(t) + 1, 1) = Application.Transpose(t) Else

Cells(myr2, 1).Resize(UBound(k) + 1, 1) = Application.Transpose(k)

Cells(myr2, 2).Resize(UBound(t) + 1, 1) = Application.Transpose(t) End If

Erase k

Erase t

Set d = Nothing

End If

End With

Next Sht

Application.ScreenUpdating = True

End Sub

5，多工作簿提取指定数据（FileSearch）

‘2011-8-31

‘/thread-759188-1-1.html

Sub GetData()

Dim Brrbz(1 To 200, 1 To 19), Brrgr(1 To 500, 1 To 23)

Dim myFs As FileSearch, myfile

Dim myPath As String, Filename$, wbnm$

Dim i&, n&, mm&, aa$, nm1$, j&

Dim Sht1 As Worksheet, sh As Worksheet, wb1 As Workbook

Application.ScreenUpdating = False

Set wb1 = ThisWorkbook

wbnm = Left(, Len() - 4)

Set Sht1 = ActiveSheet

Sht1.[a2:w200] = ""

aa = Left(, 2)

Set myFs = Application.FileSearch

myPath = ThisWorkbook.Path & "\"

With myFs

.NewSearch

.LookIn = myPath

.FileType = msoFileTypeNoteItem

.Filename = "*.xls"

.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, "\") + 1), ".")(0)

If nm1 = wbnm Then GoTo 200

Workbooks.Open myfile(i)

Dim wb As Workbook

Set wb = ActiveWorkbook

For Each sh In Sheets

If InStr(, aa) Then

sh.Activate

If aa = "班子" Then

mm = mm + 1

Brrbz(mm, 1) = [b2].Value

For j = 2 To 18 Step 2

If j < 10 Then

Brrbz(mm, j) = Cells(j / 2 + 34, 11).Value

Else

Brrbz(mm, j) = Cells(j / 2 + 34, 9).Value

End If

Next

GoTo 100

Else

If [b2] = "" Then GoTo 50

mm = mm + 1

Brrgr(mm, 1) = [b2].Value

Brrgr(mm, 2) = [e38].Value

Brrgr(mm, 3) = [i38].Value

For j = 4 To 18 Step 2

If j < 12 Then

Brrgr(mm, j) = Cells(j / 2 + 38, 8).Value

Else

Brrgr(mm, j) = Cells(j / 2 + 38, 7).Value

End If

Next

For j = 20 To 23

Brrgr(mm, j) = Cells(j + 28, 8).Value

Next

End If

End If

50:

Next

100:

wb.Close savechanges:=False

Set wb = Nothing

200:

Next

Else

MsgBox "该文件夹里没有任何文件"

End If

End With

If aa = "班子" Then

[a2].Resize(mm, 19) = Brrbz

Else

[a2].Resize(mm, 23) = Brrgr

End If

[a1].Select

Set myFs = Nothing

End Sub

‘2011-7-15

‘/viewthread.php?tid=741341&pid=5036524&page=1&extra= Sub pldrsj()

'批量导入指定文件的数据

Dim myFs As FileSearch, myfile, Brr

Dim myPath$, Filename$, nm2$

Dim i&, j&, n&, aa$, nm$

Dim Sht1 As Worksheet, sh As Worksheet

Application.ScreenUpdating = False

Set Sht1 = ActiveSheet

Sht1.Cells.ClearContents

nm2 =

Set myFs = Application.FileSearch

myPath = ThisWorkbook.Path

With myFs

.NewSearch

.LookIn = myPath

.FileType = msoFileTypeNoteItem

.Filename = "*.xls"

.SearchSubFolders = True

If .Execute(SortBy:=msoSortByFileName) > 0 Then

n = .FoundFiles.Count

ReDim Brr(1 To n, 1 To 2)

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文件名

If nm <> nm2 Then

j = j + 1

Workbooks.Open myfile(i)

Dim wb As Workbook

Set wb = ActiveWorkbook

Set sh = wb.Sheets("Sheet1")

Brr(j, 1) = nm

Brr(j, 2) = sh.[c3].Value

wb.Close savechanges:=False

Set wb = Nothing

End If

Next

Else

MsgBox "该文件夹里没有任何文件"

End If

End With

Sht1.Select

[a3].Resize(UBound(Brr), 2) = Brr

Set myFs = Nothing

Application.ScreenUpdating = True

End Sub

Sub pldrsj0707()

'/thread-456387-1-1.html

'Report 2.xls

'批量导入指定文件的数据

Dim myFs As FileSearch, myfile

Dim myPath As String, Filename$, ma&, mc&

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 & "\data" ‘指定的子文件夹搜索

With myFs

.NewSearch

.LookIn = myPath

.FileType = msoFileTypeNoteItem

.Filename = "*.xls"

.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,"\")+1),".")(0) 一句代码代替以下3句

‘aa = InStrRev(Filename, "\")

‘nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel文件名

‘nm1 = Left(nm, Len(nm) - 4) '去除后缀的Excel文件名

If nm1 <> 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行数据

…… 此处隐藏：3970字，全部文档内容请下载后查看。喜欢就下载吧 ……