VBA代码实现批量合并同一个文件夹下的所有Excel表

2024-06-28 02:06| 来源: 网络整理| 查看: 265

具体操作如下： 1、首先把要合并的多个excel表都放在同一个文件夹里面，并在这个文件夹里面新建一个excel。 2、用microsoft excel打开新建的excel表，并右键单击sheet1，找到“查看代码”，单击进去。进去之后就看到了宏计算界面。 3、然后我们把下面这些宏计算的代码复制进去，然后找到工具栏上面的“运行”下的“运行子过程/用户窗体”，代码如下，可直接复制粘贴

Sub 合并当前目录下所有工作簿的全部工作表() Dim mypath, myname, awbname Dim wb As Workbook, wbn As String Dim g As Long Dim num As Long Dim box As String Application.ScreenUpdating = False mypath = ActiveWorkbook.Path myname = Dir(mypath & "\" & "*.xls") awbname = ActiveWorkbook.Name num = 0 Do While myname "" If myname awbname Then Set wb = Workbooks.Open(mypath & "\" & myname) num = num + 1 With Workbooks(1).ActiveSheet .Cells(.Range("a65536").End(xlUp).Row + 2, 1) = Left(myname, Len(myname) - 4) For g = 1 To Sheets.Count wb.Sheets(g).UsedRange.Copy .Cells(.Range("a65536").End(xlUp).Row + 1, 1) Next wbn = wbn & Chr(13) & wb.Name wb.Close False End With End If myname = Dir Loop Range("a1").Select Application.ScreenUpdating = True MsgBox "共合并了" & num & "个工作薄下的全部工作表。如下：" & Chr(13) & wbn, vbInformation, "提示" End Sub

那么上面的代码得到的合并在一起的Excel表格表头是重复的，那该怎么去表头呢？具体的操作方法和上面一样，具体的代码看下面，直接复制就好啦。看下面的代码，下面的代码是只保留一个表头的：

Sub MergeMultiFiles() Dim filePath As String, fileName As String, mergedWorkbookName As String, processedFileNames As String Dim Workbook As Workbook Dim copyRange As Range Dim i As LongPtr Dim num As LongPtr Dim box As String Dim headerCount As Integer headerCount = 1 ' 表头行数，根据实际情况设置 Application.ScreenUpdating = False filePath = ThisWorkbook.Path fileName = Dir(filePath & "\" & "*.xls") mergedWorkbookName = ThisWorkbook.Name num = 0 Do While fileName "" If fileName mergedWorkbookName Then Set Workbook = Workbooks.Open(filePath & "\" & fileName) num = num + 1 With ThisWorkbook.ActiveSheet ' .Cells(.Range("A65535").End(xlUp).Row + 2, 1).Value = Left(fileName, Len(fileName) - 5) For i = 1 To Workbook.Sheets.Count If num = 1 And i = 1 Then Workbook.Sheets(i).UsedRange.Copy .Cells(1, 1) Else Set copyRange = Workbook.Sheets(i).UsedRange copyRange.Offset(headerCount, 0).Resize(copyRange.Rows.Count - headerCount, copyRange.Columns.Count).Copy .Cells(.Range("A65535").End(xlUp).Row + 1, 1) End If Next End With processedFileNames = processedFileNames & Chr(13) & Workbook.Name Workbook.Close False End If fileName = Dir() Loop UsedRange.Columns.AutoFit Range("A1").Select Application.ScreenUpdating = True MsgBox "共合并了" & num & "个工作薄下的全部工作表。文件名如下：" & processedFileNames, vbInformation, "提示" End Sub

参考文章： https://www.codeleading.com/article/71383848503/ https://blog.csdn.net/baidu_31950961/article/details/98640001 https://blog.csdn.net/corpse2010/article/details/89850175

【本文地址】

公司简介

联系我们