自动合并xls的代码

自动合并同目录下的excel文件内容(附完整代码)

新建Excel文件: 合并.xls

在sheet1中增加一个按钮:

点击按钮即可开始合并:

Sheet1显示文件数及每个文件的sheet数量

Sheet2即为所有文件sheet中的内容的集合:

Sheet1的vba代码:

Public Sub CommandButton1_Click() '点击开始合并

Application.ScreenUpdating = False

Application.EnableEvents = False

Application.Calculation = xlCalculationManual

Dim myFile As String

Dim myExtension As String

Dim FldrPicker As FileDialog

Dim myPath As String

Dim fileno, sheetcount, a, b As Integer

Sheets("Sheet1").Rows.Delete

Sheets("Sheet2").Rows.Delete

myPath = ThisWorkbook.path & "\" '当前路径

myFile = Dir(myPath & "*.xls*") '获取文件列表

i = 0

Do While myFile <> "" And i < 50

i = i + 1

Sheet1.Cells(i, 3) = myFile

myFile = Dir

Loop

For j = 1 To i

If Sheet1.Cells(j, 3).Text = "合并xls.xls" Then

Sheet1.Rows(j).Select

Selection.Delete

End If

Next j

Sheet1.Cells(2, 1) = i - 1 '保存文件数

For j = 1 To i - 1 '序号

Sheet1.Cells(j, 2) = j

Dim wb1 As Workbook

Set wb1 = Workbooks.Open(myPath & ThisWorkbook.Sheets("Sheet1").Cells(j, 3)) ThisWorkbook.Sheets("Sheet1").Cells(j, 4) = ActiveWorkbook.Sheets.Count '保存该文件的sheet 数量

wb1.Close

Next j

ThisWorkbook.Sheets("Sheet1").Cells(3, 1) = 1

fileno = ThisWorkbook.Sheets("Sheet1").Cells(2, 1).Value '文件总数

For a = 1 To fileno

sheetcount = ThisWorkbook.Sheets("Sheet1").Cells(a, 4).Value

For b = 1 To sheetcount

Call copysheet(myPath, ThisWorkbook.Sheets("Sheet1").Cells(a, 3), b)

Next b

Next a

Sheet1.Cells(1, 1) = "文件目录:"

ThisWorkbook.Sheets(2).Cells(1, 1).Select

MsgBox ("已完成合并:共" & ThisWorkbook.Sheets("Sheet1").Cells(2, 1).Value & "个文件." & ThisWorkbook.Sheets("Sheet1").Cells(3, 1).Value & "行!")

Application.EnableEvents = True

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

End Sub

Private Sub copysheet(path, filename, sheetNo) '复制一个sheet

Application.DisplayAlerts = False

Application.ScreenUpdating = False

Application.EnableEvents = False

Application.Calculation = xlCalculationManual

ThisWorkbook.Sheets("Sheet1").Cells(3, 1) = Sheets("Sheet1").Cells(3, 1).Value + 2

Dim wb As Workbook

Set wb = Workbooks.Open(path & filename)

wb.Activate

c = wb.Sheets(sheetNo).Cells(wb.Sheets(sheetNo).Range("C65536").End(xlUp).Row, 2).Row

d = wb.Sheets(sheetNo).Cells(wb.Sheets(sheetNo).Range("D65536").End(xlUp).Row, 3).Row

e = wb.Sheets(sheetNo).Cells(wb.Sheets(sheetNo).Range("A65536").End(xlUp).Row, 4).Row

f = Application.WorksheetFunction.Max(c, d, e) '已经使用的行数

wb.Activate

wb.Sheets(sheetNo).Activate

wb.Sheets(sheetNo).Rows(1 & ":" & f).Select

Selection.Copy

ThisWorkbook.Activate

ThisWorkbook.Sheets("Sheet2").Activate

ThisWorkbook.Sheets("Sheet2").Cells(ThisWorkbook.Sheets("Sheet1").Cells(3, 1).Value, 1).Select

ThisWorkbook.Sheets("Sheet2").Paste

ThisWorkbook.Sheets("Sheet2").Cells(Val(ThisWorkbook.Sheets("Sheet1").Cells(3, 1).Value) - 1, 1) = "合并自:" & filename & "," & wb.Sheets(sheetNo).Name

ThisWorkbook.Sheets("Sheet1").Cells(3, 1) = Sheets("Sheet1").Cells(3, 1).Value + f

wb.Close

Application.EnableEvents = True

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub