时间戳

首页 > 解决方案 > VBA将多张纸从一个wb复制到新的wb中（每张纸一个wb）

excel - VBA将多张纸从一个wb复制到新的wb中（每张纸一个wb）

问题描述

有 15 张工作表，我需要将选定工作表的内容复制到新工作簿中（每张工作表一个工作表）。下面的 VBA 有效，但我有一个部分我无法弄清楚。我从中复制的每张表都包含一个数据透视表，并且我不希望复制数据透视函数 - 只复制数据。文件大小更小。通过手动，我可以跳过数据透视表的顶部并复制“A4:BF & lr”。粘贴后，枢轴功能消失了。但我不知道如何添加通常的：

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

标签： excelvbacopy-paste

解决方案

通过使用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

推荐阅读