求助，将多张工作簿合并到一张工作簿中多个sheet，且每个sheet名称与原工作簿相同？

账房先声

如题，望VBA大神们提供帮助，具体例子在附件中

opel-wong

问题倒不难，不过你真够懒的。
表中都是空白，都没有数据结构，
从哪复制到哪呢？

账房先声

opel-wong 发表于 2020-4-9 16:56
问题倒不难，不过你真够懒的。
表中都是空白，都没有数据结构，
从哪复制到哪呢？

见笑了，确实表中是空白的。不会VBA，以为合并工作簿只涉及工作簿名称，然后内容会直接引到合并工作簿中呢。其实就是想把多个工作簿（每个工作簿只有第一张表有内容，合并成一张工作簿，之前的工作簿以sheet的形式体现）

账房先声

跟这个示例是一回事，在单个工作簿中已添加具体内容，望大神看一眼

c199300220

Sub Books2Sheets()
    '定义对话框变量
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
     
    '新建一个工作簿
    Dim newwb As Workbook
    Set newwb = Workbooks.Add
     
    With fd
        If .Show = -1 Then
            '定义单个文件变量
            Dim vrtSelectedItem As Variant
            
            '定义循环变量
            Dim i As Integer
            i = 1
            
            '开始文件检索
            For Each vrtSelectedItem In .SelectedItems
                '打开被合并工作簿
                Dim tempwb As Workbook
                Set tempwb = Workbooks.Open(vrtSelectedItem)
                 
                '复制工作表
                tempwb.Worksheets(1).Copy Before:=newwb.Worksheets(i)
                 
                '把新工作簿的工作表名字改成被复制工作簿文件名，这儿应用于xls文件，即Excel97-2003的文件，如果是Excel2007，需要改成xlsx
                newwb.Worksheets(i).Name = VBA.Replace(tempwb.Name, ".xls", "")
                 
                '关闭被合并工作簿
                tempwb.Close SaveChanges:=False
                 
                i = i + 1
            Next vrtSelectedItem
        End If
    End With
     
    Set fd = Nothing
End Sub

不知这样行不行

opel-wong

账房先声 发表于 2020-4-9 17:20
跟这个示例是一回事，在单个工作簿中已添加具体内容，望大神看一眼

你这是要求直接将目标工作薄中的工作表，复制到合并工作薄中，工作表名称用目标工作薄名，对吧？

牛掰

等待高手，踩下脚印

dyhq2012

Sub 工作薄间工作表合并()
    Dim FileOpen
    Dim i As Integer
    FileOpen = Application.GetOpenFilename("Excel文件,*.xls;*.xlsx;*.xslm", MultiSelect:=True) '电脑中选一个或多个工作薄构成数组
    If TypeName(FileOpen) <> "Boolean" Then   '如果选择了至少一个工作薄，就……
        For i = 1 To UBound(FileOpen)
             Workbooks.Open Filename:=FileOpen(i)
Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

        Next
   End If
End Sub

wangyuhui7

看看这个  

kunxu

wangyuhui7 发表于 2021-4-30 15:19
看看这个

厉害，感谢，新人去学习一下