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

1，多工作表汇总（Consolidate）

‘.excelpx./dispbbs.asp?boardID=5&ID=110630&page=1

‘两种写法都要求地址用R1C1形式，各个表格的数据布置有规定。

Sub ConsolidateWorkbook()

Dim RangeArray() As String

Dim bk As Worksheet

Dim sht As Worksheet

Dim WbCount As Integer

Set bk = Sheets("汇总")

WbCount = Sheets.Count

ReDim RangeArray(1 To WbCount - 1)

For Each sht In Sheets

If <> "汇总" Then

i = i + 1

RangeArray(i) = "'" & & "'!" & _

sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)

End If

Next

bk.Range("A1").Consolidate RangeArray, xlSum, True, True

[a1].Value = ""

End Sub

Sub sumdemo()

Dim arr As Variant

arr = Array("一月!R1C1:R8C5", "二月!R1C1:R5C4", "三月!R1C1:R9C6") With Worksheets("汇总").Range("A1")

.Consolidate arr, xlSum, True, True

.Value = ""

End With

End Sub

2，多工作簿汇总（Consolidate）

‘多工作簿汇总

Sub ConsolidateWorkbook()

Dim RangeArray() As String

Dim bk As Workbook

Dim sht As Worksheet

Dim WbCount As Integer

WbCount = Workbooks.Count

ReDim RangeArray(1 To WbCount - 1)

For Each bk In Workbooks '在所有工作簿中循环

If Not bk Is ThisWorkbook Then '非代码所在工作簿

Set sht = bk.Worksheets(1) '引用工作簿的第一个工作表

i = i + 1

RangeArray(i) = "'[" & & "]" & & "'!" & _ sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)

End If

Next

Worksheets(1).Range("A1").Consolidate _

RangeArray, xlSum, True, True

End Sub

3，多工作簿汇总（FileSearch）

‘/thread-442007-1-1.html###

‘help\汇总表.xls

Sub pldrwb0531()

'汇总表.xls

'导入指定文件的数据

Dim myFs As FileSearch

Dim myPath As String, Filename$

Dim i As Long, n As Long

Dim Sht1 As Worksheet, sh As Worksheet

Dim aa, nm$, nm1$, m, arr, r1, col1%

Application.ScreenUpdating = False

Set Sht1 = ActiveSheet

Set myFs = Application.FileSearch

myPath = ThisWorkbook.Path

With myFs

.NewSearch

.LookIn = myPath

.FileType = msoFileTypeNoteItem

.Filename = "*.xls"

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

n = .FoundFiles.Count

col1 = 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)

nm1 = Left(nm, Len(nm) - 4)

If nm1 <> "汇总表" Then

Workbooks.Open myfile(i)

Dim wb As Workbook

Set wb = ActiveWorkbook

m = [a65536].End(xlUp).Row

arr = Range(Cells(3, 3), Cells(m, 3))

Sht1.Activate

col1 = col1 + 1

Cells(2, col1) = nm '自动获取文件名

Cells(3, col1).Resize(UBound(arr), 1) = arr

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

‘根据上例增加了在一个工作簿中可选择多个工作表进行汇总，运用了文本框多选功能Public ar, ar1, nm$

Sub pldrwb0531()

'汇总表.xls

'导入指定文件的数据（默认工作表1的数据）

'直接从C列依次导入

Dim myFs As FileSearch

Dim myPath As String, Filename$

Dim i As Long, n As Long

Dim Sht1 As Worksheet, sh As Worksheet

Dim aa, nm1$, m, arr, r1, col1%

Application.ScreenUpdating = False

On Error Resume Next

Set Sht1 = ActiveSheet

Set myFs = Application.FileSearch

myPath = ThisWorkbook.Path

With myFs

.NewSearch

.LookIn = myPath

.FileType = msoFileTypeNoteItem

.Filename = "*.xls"

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

n = .FoundFiles.Count

col1 = 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)

nm1 = Left(nm, Len(nm) - 4)

If nm1 <> "汇总表" Then

Workbooks.Open myfile(i)

Dim wb As Workbook

Set wb = ActiveWorkbook

For Each sh In Sheets

s = s & & ","

Next

s = Left(s, Len(s) - 1)

ar = Split(s, ",")

UserForm1.Show

For j = 0 To UBound(ar1)

If Err.Number = 9 Then GoTo 100

Set sh = wb.Sheets(ar1(j))

sh.Activate

m = sh.[a65536].End(xlUp).Row

arr = Range(Cells(3, 3), Cells(m, 3))

Sht1.Activate

col1 = col1 + 1

Cells(2, col1) = sh.[a1]

Cells(3, col1).FormulaR1C1 = "=[" & nm & "]" & ar1(j) & "!RC3" ‘显示引用的工作簿工作表及单元格地址

Cells(3, col1).AutoFill Range(Cells(3, col1), Cells(UBound(arr) + 2, col1))

‘Cells(3, col1).Resize(UBound(arr), 1) = arr

Next j

100: wb.Close savechanges:=False

Set wb = Nothing

s = ""

If VarType(ar1) = 8200 Then Erase ar1

End If

Next

Else

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

End If

End With

[a1].Select

Set myFs = Nothing

Application.ScreenUpdating = True

End Sub

Private Sub CommandButton1_Click()

For i = 0 To ListBox1.ListCount - 1

If ListBox1.Selected(i) = True Then

s = s & ListBox1.List(i) & ","

End If

Next i

If s <> "" Then

s = Left(s, Len(s) …… 此处隐藏：3621字，全部文档内容请下载后查看。喜欢就下载吧 ……