复制多个工作簿的指定工作表到新的工作簿，并以原工作簿的名称命名新工作表

chenzhen_0912

请教各位大神，如何将多个工作簿中的“2-措施项目”工作表复制到新的工作簿中，并以原工作簿的名称命名新工作簿中的工作表

清风竹-

请看附件。

chenzhen_0912

清风竹- 发表于 2019-10-4 21:30
请看附件。

非常感谢大神，完美解决

约定的童话

能力有限，两段代码实现：Sub 汇总()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim MyPath, MyName, AWbName, Wb As Workbook
    MyPath = ThisWorkbook.Path & "\"
    MyName = Dir(MyPath & "*.xlsx")
    AWbName = ActiveWorkbook.Name
    Do While MyName <> ""
        If MyName <> AWbName Then
            Set Wb = Workbooks.Open(MyPath & "\" & MyName)
            With Workbooks(1)
                Sheets("2-措施项目").Copy Workbooks("汇总.xlsm").Sheets("汇总")
                Wb.Close False
            End With
        End If
        MyName = Dir
    Loop
    Call 命名
    MsgBox "汇总完毕！", , "报告！"
    Application.ScreenUpdating = True
End Sub
Sub 命名()
    Dim i, sht As Worksheet
    For Each sht In Worksheets
        If sht.Name <> "汇总" Then
            sht.Name = Split(sht.[a2], " ")(1)
        End If
    Next
End Sub