如何将一个文件夹里的多个工作簿变成新工作簿里的多个工作表

pjypl1688888

如何将一个文件夹里的多个工作簿变成新工作簿里的多个工作表，请发个压缩包，多谢

一执成念

Sub CombineSheets()
    Dim wbSource As Workbook
    Dim wbTarget As Workbook
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim folderPath As String
    Dim fileName As String
    Dim NewSheetName As String
    Dim i As Integer
    Dim FileExt As String
    ' 此处替换为你的文件夹路径
    folderPath = "C:\Users\Administrator\Downloads\文件\"
    savePath = "C:\Users\Administrator\Downloads\文件\合并.xlsx"
    Application.ScreenUpdating = False
    fileName = Dir(folderPath & "*.xls*")
    Set wbTarget = Workbooks.Add
    Do While fileName <> ""
        Set wbSource = Workbooks.Open(folderPath & fileName)
        For Each wsSource In wbSource.Sheets
            FileExt = Mid(fileName, InStrRev(fileName, ".") + 1)
            NewSheetName = Left(fileName, Len(fileName) - Len(FileExt) - 1) & "_" & wsSource.Name
            wsSource.Copy After:=wbTarget.Sheets(wbTarget.Sheets.Count)
            Set wsTarget = wbTarget.Sheets(wbTarget.Sheets.Count)
            wsTarget.Name = NewSheetName
        Next wsSource
        wbSource.Close SaveChanges:=False
        fileName = Dir
    Loop
    ' 保存新的工作簿
    wbTarget.SaveAs savePath
    ' 关闭新的工作簿
    wbTarget.Close SaveChanges:=False
    Application.ScreenUpdating = True
    MsgBox "所有工作表已成功复制到新文件中！"
End Sub

Sub CombineSheets()
    Dim wbSource As Workbook
    Dim wbTarget As Workbook
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim folderPath As String
    Dim fileName As String
    Dim NewSheetName As String
    Dim i As Integer
    Dim FileExt As String
    ' 此处替换为你的文件夹路径
    folderPath = "C:\Users\Administrator\Downloads\文件\"
    savePath = "C:\Users\Administrator\Downloads\文件\合并.xlsx"
    Application.ScreenUpdating = False
    fileName = Dir(folderPath & "*.xls*")
    Set wbTarget = Workbooks.Add
    Do While fileName <> ""
        Set wbSource = Workbooks.Open(folderPath & fileName)
        For Each wsSource In wbSource.Sheets
            FileExt = Mid(fileName, InStrRev(fileName, ".") + 1)
            NewSheetName = Left(fileName, Len(fileName) - Len(FileExt) - 1) & "_" & wsSource.Name
            wsSource.Copy After:=wbTarget.Sheets(wbTarget.Sheets.Count)
            Set wsTarget = wbTarget.Sheets(wbTarget.Sheets.Count)
            wsTarget.Name = NewSheetName
        Next wsSource
        wbSource.Close SaveChanges:=False
        fileName = Dir
    Loop
    ' 保存新的工作簿
    wbTarget.SaveAs savePath
    ' 关闭新的工作簿
    wbTarget.Close SaveChanges:=False
    Application.ScreenUpdating = True
    MsgBox "所有工作表已成功复制到新文件中！"
End Sub

一执成念

代码发不出去？？

Enocheasty

推销一下我的插件，可以将所所选文件中的选择的工作表的指定列的内容拼接到一个工作表中。做演示GIF还要做数据，懒得做了，如果使用的话，可以看看插件在线使用说明。
自编的插件Excel助手更新V1.1-VSTO-ExcelHome技术论坛 -

一执成念

Enocheasty 发表于 2024-11-17 10:35
推销一下我的插件，可以将所所选文件中的选择的工作表的指定列的内容拼接到一个工作表中。做演示GIF还要做 ...

我发现WPS自带这个功能

Enocheasty

一执成念 发表于 2024-11-17 14:32
我发现WPS自带这个功能

没用过WPS，这些插件的功能基本是自己瞎琢磨的，还有看论坛里的各种奇怪需求。

一执成念

Enocheasty 发表于 2024-11-18 09:14
没用过WPS，这些插件的功能基本是自己瞎琢磨的，还有看论坛里的各种奇怪需求。

论坛里通用需求可加到插件里

Enocheasty

一执成念 发表于 2024-11-18 09:22
论坛里通用需求可加到插件里

说实话，在论坛逛了有段时间了，大部情况下，我觉得那些需求比较简单，甚至都用不了VBA去解决。有的需求倒是需要VBA，但是太特别了，写一次都麻烦，对于个人来说有复用性，但是对于很多人来说，又感觉没啥用。有的又太复杂了，比如排班的NP难问题。所以最终其实在论坛里吸收的东西不多。
好久没有什么好点子了。。。

一执成念

Enocheasty 发表于 2024-11-18 14:34
说实话，在论坛逛了有段时间了，大部情况下，我觉得那些需求比较简单，甚至都用不了VBA去解决。有的需求 ...

也是，继续琢磨吧