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

Question

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

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

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

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

Answer 1

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

也就是说，这会做你想做的事，它会在产生你当前遇到的错误的工作簿中工作。

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