使用VBA进行Excel表格汇总

武汉市审计局  李登宇

在审计工作中，经常需要进行大量的excel表格汇总，人工复制粘贴不仅耗费大量时间精力，且容易出错，VBA是Visual Basic的一种宏语言，可以扩展excel功能，使工作自动化，提高工作效率。下面介绍如何使用VBA进行几种不同的表格汇总。

一、同一个工作薄中的不同工作表进行汇总

在工作薄中新建一个工作表作为汇总工作表，使用ALT+F11打开编辑器，新建模块，输入如下代码后，按F5运行此宏。

Sub 合并当前工作簿下的所有工作表()

Application.ScreenUpdating = False

For j = 1 To Sheets.Count

If Sheets(j).Name <> ActiveSheet.Name Then

X = Range("A65536").End(xlUp).Row + 1

Sheets(j).UsedRange.Copy Cells(X, 1)

End If

Next

End Sub

二、合并不同工作薄中的所有工作表（汇总后的表格不在一个sheet中）

首先，将所有需要汇总的工作薄放入同一个文件夹，在该文件夹中新建一个工作薄作为汇总工作薄。其次，打开汇总工作薄，使用ALT+F11打开编辑器，新建模块，输入如下代码后，按F5运行此宏。

Sub Find()

Application.ScreenUpdating = False

Dim MyDir As String

MyDir = ThisWorkbook.Path & "\"

ChDrive Left(MyDir, 1) 'find all the excel files

ChDir MyDir

Match = Dir$("")

Do

If Not LCase(Match) = LCase(ThisWorkbook.Name) Then

Workbooks.Open Match, 0 'open

ActiveSheet.Copy

Before:=ThisWorkbook.Sheets(1) 'copy sheet

Windows(Match).Activate

ActiveWindow.Close

End If

Match = Dir$

Loop Until Len(Match) = 0

Application.ScreenUpdating = True

End Sub

三、合并不同工作薄中的同名工作表（同名工作表在同一sheet中）

首先，将所有需要汇总的工作薄放入同一个文件夹，在该文件夹中新建一个工作薄作为汇总工作薄。其次，打开汇总工作薄，使用ALT+F11打开编辑器，新建模块，输入如下代码后，按F5运行此宏。

Sub Macro1()

Dim MyPath$, MyName$, sh As Worksheet, d As Object, r&

Set d = CreateObject("scripting.dictionary")

MyPath = ThisWorkbook.Path & "\"

MyName = Dir(MyPath & "*.xls")

Application.ScreenUpdating = False

Application.DisplayAlerts = False

For Each sh In Sheets

If sh.Name <> ActiveSheet.Name Then sh.Delete

Next

Do While MyName <> ""

If MyName <> ThisWorkbook.Name Then

With GetObject(MyPath & MyName)

For Each sh In .Sheets

If IsSheetEmpty = IsEmpty(sh.UsedRange) Then

If Not d.Exists(sh.Name) Then

sh.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

Set d(sh.Name)=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

Else

With d(sh.Name)

r = .UsedRange.Row + .UsedRange.Rows.Count + 2

sh.UsedRange.Copy .Cells(r, 1)

End With

End If

End If

Next

.Close False

End With

End If

MyName = Dir

Loop

Sheets(1).Activate

Application.ScreenUpdating = True

End Sub

使用VBA进行Excel表格汇总

武汉市审计局  李登宇

在审计工作中，经常需要进行大量的excel表格汇总，人工复制粘贴不仅耗费大量时间精力，且容易出错，VBA是Visual Basic的一种宏语言，可以扩展excel功能，使工作自动化，提高工作效率。下面介绍如何使用VBA进行几种不同的表格汇总。

一、同一个工作薄中的不同工作表进行汇总

在工作薄中新建一个工作表作为汇总工作表，使用ALT+F11打开编辑器，新建模块，输入如下代码后，按F5运行此宏。

Sub 合并当前工作簿下的所有工作表()

Application.ScreenUpdating = False

For j = 1 To Sheets.Count

If Sheets(j).Name <> ActiveSheet.Name Then

X = Range("A65536").End(xlUp).Row + 1

Sheets(j).UsedRange.Copy Cells(X, 1)

End If

Next

End Sub

二、合并不同工作薄中的所有工作表（汇总后的表格不在一个sheet中）

首先，将所有需要汇总的工作薄放入同一个文件夹，在该文件夹中新建一个工作薄作为汇总工作薄。其次，打开汇总工作薄，使用ALT+F11打开编辑器，新建模块，输入如下代码后，按F5运行此宏。

Sub Find()

Application.ScreenUpdating = False

Dim MyDir As String

MyDir = ThisWorkbook.Path & "\"

ChDrive Left(MyDir, 1) 'find all the excel files

ChDir MyDir

Match = Dir$("")

Do

If Not LCase(Match) = LCase(ThisWorkbook.Name) Then

Workbooks.Open Match, 0 'open

ActiveSheet.Copy

Before:=ThisWorkbook.Sheets(1) 'copy sheet

Windows(Match).Activate

ActiveWindow.Close

End If

Match = Dir$

Loop Until Len(Match) = 0

Application.ScreenUpdating = True

End Sub

三、合并不同工作薄中的同名工作表（同名工作表在同一sheet中）

首先，将所有需要汇总的工作薄放入同一个文件夹，在该文件夹中新建一个工作薄作为汇总工作薄。其次，打开汇总工作薄，使用ALT+F11打开编辑器，新建模块，输入如下代码后，按F5运行此宏。

Sub Macro1()

Dim MyPath$, MyName$, sh As Worksheet, d As Object, r&

Set d = CreateObject("scripting.dictionary")

MyPath = ThisWorkbook.Path & "\"

MyName = Dir(MyPath & "*.xls")

Application.ScreenUpdating = False

Application.DisplayAlerts = False

For Each sh In Sheets

If sh.Name <> ActiveSheet.Name Then sh.Delete

Next

Do While MyName <> ""

If MyName <> ThisWorkbook.Name Then

With GetObject(MyPath & MyName)

For Each sh In .Sheets

If IsSheetEmpty = IsEmpty(sh.UsedRange) Then

If Not d.Exists(sh.Name) Then

sh.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

Set d(sh.Name)=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

Else

With d(sh.Name)

r = .UsedRange.Row + .UsedRange.Rows.Count + 2

sh.UsedRange.Copy .Cells(r, 1)

End With

End If

End If

Next

.Close False

End With

End If

MyName = Dir

Loop

Sheets(1).Activate

Application.ScreenUpdating = True

End Sub