VBA将多张图纸从一个wb复制到新的wb中(每张图纸一个wb)

Question

我得到了一个有15张工作表的wb，我需要将所选工作表的内容复制到新的工作簿中(每个工作表一个wb )。下面的VBA可以工作，但我有一个部分我搞不懂。我复制的每个工作表都包含一个数据透视表，我不希望复制数据透视表函数--只复制数据。文件大小更小。通过手动操作，我可以跳过透视表的顶部并复制"A4:BF & lr“。粘贴后，pivot-functions将消失。但我想不出该如何添加通常的：

lr = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("A4:BF" & lr).Copy

..。到我的vba中(它不会运行)。我想最简单的是如果有一个函数可以让我复制整个工作表而不使用透视函数，但我也不知道如何实现这个函数。有什么想法吗？

Sub Test_KIT()

Dim ws As Worksheet

Application.ScreenUpdating = False

    For Each ws In ThisWorkbook.Worksheets

    If Left(ws.Name, 4) = "s2g1" Or Left(ws.Name, 4) = "s2g2" Then
    ws.Copy

    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\ABC1_999_" & ws.Name & ".xlsx"
    ActiveWorkbook.Close SaveChanges:=False

      End If

    Next ws

End Sub

Answer 1

通过使用BigBen的想法，以及其他一些更改，这段代码现在可以做我想让它做的事情了。非常感谢你的帮助！

Sub Test_KIT4()

Dim ws As Worksheet
Dim NewBook As Workbook

Application.ScreenUpdating = False

    For Each ws In ThisWorkbook.Worksheets

        Set NewBook = Workbooks.Add
        If ws.Name <> "DATA_ske_ferdigFU" Then

        lr = ws.Range("A" & Rows.Count).End(xlUp).Row
        ws.Range("A4:BF" & lr).Copy
        NewBook.ActiveSheet.Paste

        NewBook.SaveAs ThisWorkbook.Path & "\ABC1_999_" & ws.Name & ".xlsx"
        NewBook.Close SaveChanges:=False

    End If

  Next ws

NewBook.Close SaveChanges:=False

End Sub