copy all sheets with actual data range into new workbooks while maintaining old sheets names

Question

I have to copy every sheets only with actual data range.

I tried two codes. One is for creating new workbooks, worksheets and renaming sheets. Another is for copying actual data range. Both works fine. While I tried to combine these two codes, it doesn't work anymore.

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

It is giving run time error. It is because of the codes under Copy and Paste comment.

Note that "doesn't work" is no useful error description. Also it is necessary to tell which error you get and in which line. Please edit your question to add these information. — Pᴇʜ

ProfoundlyOblivious ProfoundlyOblivious · Accepted Answer · 2019-07-12T08:34:14

It looks like you copied and pasted code then tried to splice it without actually understanding it. Considering that, I don't know if this will actually help you because you're not going to learn anything.

That said, this will do what you want and it will work in the workbook that is generating the error you currently have.

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

copy all sheets with actual data range into new workbooks while maintaining old sheets names

1 Answers