Question

您好，我们有一个包含80个工作表的工作簿，我只希望选择4个具有选定范围的工作表。我想自动将此范围复制到一个新的工作簿。我已经运行了一个宏，下面的代码。有人可以帮忙吗。提前考虑。

Sub TestTest()
'
 ' TestTest Macro
 '

 '
  Sheets("Summary").Select
  Range("A1:O54").Select
  Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:="Newworkbook.xlsx", 
 FileFormat:= _
    xlOpenXMLWorkbook, CreateBackup:=False
Windows("").Activate
Sheets("").Select
Range("").Select
Selection.Copy
Windows("Newworkbook.xlsx").Activate
Sheets.Add After:=ActiveSheet
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("").Activate
Sheets("").Select
Range("").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Newworkbook.xlsx").Activate
Sheets.Add After:=ActiveSheet
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("").Activate
Sheets("").Select
Range("").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Newworkbook.xlsx").Activate
Sheets.Add After:=ActiveSheet
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("").Activate
Sheets("").Select
ActiveWindow.SmallScroll Down:=-18
Range("").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Newworkbook.xlsx").Activate
Sheets.Add After:=ActiveSheet
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Windows("").Activate
Range("N29").Select
End Sub

Answer 1

我相信它应该可以按您预期的方式工作，它将复制所有五个范围并将它们粘贴到新的工作簿中，适当地重命名每个工作表，然后将新创建的工作簿保存到所需的位置，您可能想要在正在创建的新工作簿的名称中添加一些内容（例如日期），以便下次运行代码时不会出现任何问题，或者可以删除以前的报告并将其覆盖：

Sub Test()
Dim wsSummary As Worksheet: Set wsSummary = ThisWorkbook.Sheets("Summary")
Dim wsMeasured As Worksheet: Set wsMeasured = ThisWorkbook.Sheets("1. Measured Work")
Dim wsPreliminaries As Worksheet: Set wsPreliminaries = ThisWorkbook.Sheets("2. Preliminaries")
Dim wsFees As Worksheet: Set wsFees = ThisWorkbook.Sheets("3. Fees")
Dim wsContingency As Worksheet: Set wsContingency = ThisWorkbook.Sheets("4. Contingency")
Dim NewWorkBook As Workbook
'above declare and set the worksheets and workbook you are working with
Application.ScreenUpdating = False
    Set NewWorkBook = Workbooks.Add
    'add a new workbook

    wsSummary.Range("A1:O54").Copy 'copy first range
    NewWorkBook.Sheets(1).Range("A1").PasteSpecial xlPasteValues
    NewWorkBook.Sheets(1).Range("A1").PasteSpecial xlPasteFormats
    'paste into first sheet in new workbook
    NewWorkBook.Sheets(1).Name = "Summary" 'rename the sheet in the new workbook

    wsMeasured.Range("B1:Q76").Copy 'copy second range
    NewWorkBook.Sheets.Add After:=ActiveSheet 'add a new sheet to the new workbook
    NewWorkBook.Sheets(2).Range("A1").PasteSpecial xlPasteValues
    NewWorkBook.Sheets(2).Range("A1").PasteSpecial xlPasteFormats
    'paste into second sheet in new workbook
    NewWorkBook.Sheets(2).Name = "1. Measured Work" 'rename the sheet in the new workbook

    wsPreliminaries.Range("B1:Q48").Copy 'copy third range
    NewWorkBook.Sheets.Add After:=ActiveSheet 'add a new sheet to the new workbook
    NewWorkBook.Sheets(3).Range("A1").PasteSpecial xlPasteValues
    NewWorkBook.Sheets(3).Range("A1").PasteSpecial xlPasteFormats
    'paste into third sheet in new workbook
    NewWorkBook.Sheets(3).Name = "2. Preliminaries" 'rename the sheet in the new workbook

    wsFees.Range("B1:Q47").Copy 'copy fourth range
    NewWorkBook.Sheets.Add After:=ActiveSheet 'add a new sheet to the new workbook
    NewWorkBook.Sheets(4).Range("A1").PasteSpecial xlPasteValues
    NewWorkBook.Sheets(4).Range("A1").PasteSpecial xlPasteFormats
    'paste into fourth sheet in new workbook
    NewWorkBook.Sheets(4).Name = "3. Fees" 'rename the sheet in the new workbook

    wsContingency.Range("B1:Q46").Copy 'copy fifth range
    NewWorkBook.Sheets.Add After:=ActiveSheet 'add a new sheet to the new workbook
    NewWorkBook.Sheets(5).Range("A1").PasteSpecial xlPasteValues
    NewWorkBook.Sheets(5).Range("A1").PasteSpecial xlPasteFormats
    'paste into fifth sheet in new workbook
    NewWorkBook.Sheets(5).Name = "4. Contingency" 'rename the sheet in the new workbook
    Application.CutCopyMode = False 'deselect copied range

    NewWorkBook.SaveAs Filename:="NewWorkBook.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    'save the newly created workbook
    NewWorkBook.Close
    'close the newly created workbook
Application.ScreenUpdating = True
End Sub

VBA通过自动创建新工作簿将所选的多个工作表复制到工作簿的数据范围

1 个答案: