事情的起因

今天在维护公司网站的时候看了下之前崩掉的网站，看看能不能通过数据库抢救回一些数据，将原本的那些文章转移到前阵子我刚开发的网站上，但是由于那个项目使用的是 ASP + Microsoft Database，所以只能用 Microsoft Access 查看数据库，结果发现数据库里面啥都有，这里就不展示了。
为了方便下次查看数据库，我准备转换成 Excel 表格，但是研究了半天发现只能一张一张表导出（别问为什么不直接用 Excel 表格索引这个数据库，问就是当时玩嗨了忘了），然后看了好多网上那些合并工作簿的方法，还使用了他们的 VB 代码，结果不太行

解决方案

后来实在懒得验证网友们的代码了，干脆让 Chat GPT 给我写一段，有问题后续在调试。
要求：将当前文件夹中的所有工作簿（.xlsx）文件的第一张表都拷贝到当前工作簿中，新得到的表名为原工作簿的文件名。
于是，就得到了下面这段代码，亲测有效。

Sub MergeExcelSheets()
    Dim folderPath As String
    Dim currentFile As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim targetWb As Workbook

    ' 获取当前文件夹路径
    folderPath = ThisWorkbook.Path & "\"

    ' 循环处理文件夹中的所有 .xlsx 文件
    currentFile = Dir(folderPath & "*.xlsx")

    Do While currentFile <> ""
        ' 排除当前文件
        If currentFile <> ThisWorkbook.Name Then
            ' 打开当前文件
            Set wb = Workbooks.Open(folderPath & currentFile)

            ' 复制第一张表到本文件中
            Set targetWb = ThisWorkbook
            Set ws = wb.Sheets(1)
            ws.Copy after:=targetWb.Sheets(targetWb.Sheets.Count)
            targetWb.Sheets(targetWb.Sheets.Count).Name = Left(currentFile, InStrRev(currentFile, ".") - 1)

            ' 关闭当前文件
            wb.Close False
        End If

        ' 继续处理下一个文件
        currentFile = Dir
    Loop

    ' 弹出消息框显示合并成功
    MsgBox "合并成功"
End Sub

优化方案

完成我的需求后我觉得这段代码局限性太大了，于是我就将拷贝第一张表的需求改为了全部工作表，并且新的表名命名规则为：原文件名-原表名
于是，下面这段优化代码就这样诞生了。

Sub MergeAllExcelSheets()
    Dim folderPath As String
    Dim currentFile As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim targetWb As Workbook
    Dim sheetName As String

    ' 获取当前文件夹路径
    folderPath = ThisWorkbook.Path & "\"

    ' 循环处理文件夹中的所有 .xlsx 文件
    currentFile = Dir(folderPath & "*.xlsx")

    Do While currentFile <> ""
        ' 排除当前文件
        If currentFile <> ThisWorkbook.Name Then
            ' 打开当前文件
            Set wb = Workbooks.Open(folderPath & currentFile)

            ' 循环复制每个工作表到本文件中
            For Each ws In wb.Sheets
                Set targetWb = ThisWorkbook
                ws.Copy after:=targetWb.Sheets(targetWb.Sheets.Count)
                sheetName = Left(currentFile, InStrRev(currentFile, ".") - 1) & "-" & ws.Name
                targetWb.Sheets(targetWb.Sheets.Count).Name = sheetName
            Next ws

            ' 关闭当前文件
            wb.Close False
        End If

        ' 继续处理下一个文件
        currentFile = Dir
    Loop

    ' 弹出消息框显示合并成功
    MsgBox "合并成功"
End Sub

写在最后

以上代码都是针对 .xlsx 格式的文件，所以如果要针对其他格式的文件只需要修改代码中的后缀即可。

如果有啥写的不对的地方欢迎指正。