Excel 将所有具有实际数据范围的图纸复制到新工作簿中，同时保留旧图纸名称

我必须只复制具有实际数据范围的每张图纸

我试了两个密码。一种是创建新工作簿、工作表和重命名工作表。另一个是用于复制实际数据范围。两者都很好。当我试图结合这两个代码时，它不再起作用了

Sub dural()
   Dim b1 As Workbook, b2 As Workbook

   Set b2 = ActiveWorkbook
   Set b1 = Workbooks.Add

   For Each sh2 In b2.Sheets
      Set sh1 = b1.Sheets.Add
      sh1.Name = sh2.Name

'   Show hide Columns and Rows
      sh2.Columns.EntireColumn.Hidden = False
         Rows.EntireRow.Hidden = False
'   Unfilter
    If sh2.FilterMode = True Then
        sh2.ShowAllData
    End If

'   Copy and Paste
    sh2.Range("A1").Resize(Cells.Find(What:="*", SearchOrder:=xlRows, _
        SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
        Cells.Find(What:="*", SearchOrder:=xlByColumns, _
        SearchDirection:=xlPrevious, LookIn:=xlValues).Column).Copy _
        sh1.Range("A1")

   Next sh2
End Sub

---

它给出了运行时错误。这是因为“复制和粘贴注释”下的代码。

看起来您复制和粘贴了代码，然后试图拼接它，但实际上并没有理解它。考虑到这一点，我不知道这是否真的对你有帮助，因为你不会学到任何东西

这就是说，这将执行您想要的操作，并且它将在生成当前错误的工作簿中工作

Sub dural()
    Dim b1 As Workbook, b2 As Workbook
    Dim sh1 As Worksheet, sh2 As Worksheet

    Set b2 = ActiveWorkbook
    Set b1 = Workbooks.Add

    For Each sh2 In b2.Sheets
        With sh2
            Set sh1 = b1.Sheets.Add
            sh1.Name = .Name

            '   Show hide Columns and Rows
            .Columns.EntireColumn.Hidden = False
            .Rows.EntireRow.Hidden = False

            '   Unfilter
            If .FilterMode = True Then .ShowAllData

            '   Copy and Paste
            .UsedRange.Copy sh1.Range(.UsedRange.Address)
        End With
    Next sh2
End Sub

---

请注意，没有有用的错误描述是不起作用的。另外，有必要告诉您在哪一行中出现了哪一个错误。请用你的问题来添加这些信息。它给了你什么错误？我只修改了一行，它非常适合我。如果是sh1.Name.Name，那么是sh1.Name=.Name。我不知道vba。在我的办公室，excel用户意外地保存了一些不可见的设置。工作簿变大且无响应。所以，这就是为什么我想做这个代码。谢谢你。我将开始学习一些vba技能。很好地发现了潜在的错误，它几乎保证会很快弹出。如果您觉得可以，可以尝试创建一个循环，在图纸名称已经存在的情况下为其添加后缀，或者提示用户指定图纸名称。