Question

我有工作簿，我想将很多工作表一张一张地复制到新工作簿并重命名工作簿

我尝试过，但是它保存在一个工作簿中而不是单独的工作簿中，我也不想复制第一个工作表来复制新工作簿

Option Explicit

Sub CreateWorkBooks()
    Dim ws As Object
    Dim i As Long
    Dim ws_num As Integer
    Application.ScreenUpdating = False

    Set ws = Worksheets
    ws_num = ThisWorkbook.Worksheets.Count

    For i = 2 To ws_num
        'Copy one worksheet as a new workbook
        'The new workbook becomes the ActiveWorkbook
        ws.Copy

        'Replace all formulas with values (optional)
        ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value

        'May want (not required) to add a file name extension (.xls or .xlsx) to the file name
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & _
          "AR Balance- " & ActiveSheet.Name & " " & Worksheets("DATA Sheet").Range("m2") & ".xlsx"
        ActiveWorkbook.Close SaveChanges:=False 
    Next 

    Application.ScreenUpdating = True
End Sub

Answer 1

欢迎来到SO。仅进行简单的自我解释性更正。试试

 Option Explicit
Sub CreateWorkBooks()
    Dim ws As Worksheet  ' Worksheets instead of Object
    Dim i As Long
    Dim ws_num As Integer
    'Application.ScreenUpdating = False


    ws_num = ThisWorkbook.Worksheets.Count

    For i = 2 To ws_num
    Set ws = ThisWorkbook.Worksheets(i)      'set ws to each sheet in the workbook
        'Copy one worksheet as a new workbook
        'The new workbook becomes the ActiveWorkbook
        ws.Copy

        'Replace all formulas with values (optional)
        ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value

        'May want (not required) to add a file name extension (.xls or .xlsx) to the file name
        ' Thisworkbook  is to be added to refer Worksheets("DATA Sheet").Range("m2").Value
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & _
          "AR Balance- " & ActiveSheet.Name & " " & ThisWorkbook.Worksheets("DATA Sheet").Range("m2").Value & ".xlsx"

        ActiveWorkbook.Close False
    Next

    'Application.ScreenUpdating = True
End Sub

工作簿工作表复制到多个工作簿并重命名

1 个答案: