Delete unwanted sheets while copy the Workbook.

Hi Experts,

The attached macro able to copy and paste the workbook (attached) in a different location by removing “Data” sheet, other sheets are remained. Is that possible to revise the macro to delete all the sheets except “Data sheet”. The “Data” sheet should only consist Column A:C data and delete other object,  e.g. pictures. Hope Experts could help.



Sub exportWorkbook()
Dim fName As String
Dim wkb As Workbook
Dim wks As Worksheet
Dim mySht As Worksheet
Dim mySheets() As String
Dim i As Long
Dim newWkb As Workbook

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Set wkb = ThisWorkbook
    Set wks = wkb.Sheets("Data")
    
    fName = "D:\File Recovery\" & wks.Range("A1").Value & wks.Range("C4").Value & ".xls"
    'fName = ThisWorkbook.Path & "\" & wks.Range("A3").Value & wks.Range("C3").Value & ".xls"
    
    For Each mySht In ThisWorkbook.Worksheets
        If mySht.Name <> "Data" Then
            ReDim Preserve mySheets(i) As String
            mySheets(i) = mySht.Name
            i = i + 1
        End If
    Next mySht
    
    ReDim Preserve mySheets(UBound(mySheets) - 1)
    
    ThisWorkbook.Sheets(mySheets).Copy
    'Call RemoveAllMacros(ActiveWorkbook) 'in case there are macros in the sheet's codepages
    ActiveWorkbook.SaveAs Filename:=fName, FileFormat:=xlExcel8
    ActiveWorkbook.Close
    
    MsgBox "Successful export of " & fName
    Application.DisplayAlerts = False
    Application.ScreenUpdating = True
End Sub

Open in new window

Export-Sheet.xls
Billa7Asked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

StephenJRCommented:
If you use Move in line 29 instead of Copy, you won't need to delete them from the original. And for the other bit, try this:
With Sheets("Data")
        .UsedRange.Offset(, 3).Clear
        .DrawingObjects.Delete
    End With

Open in new window

0
Billa7Author Commented:
Hi Stephen JR,

I have tried by modifying this line "ThisWorkbook.Sheets(mySheets).Move". However,I'm still getting the same result ("Data" has been deleted and other sheets "week 1 to week 5" are still exist). Meantime, I'm not very sure where to add the "other bit" line in my original code. Please assist.

0
StephenJRCommented:
This seems to work for me:
Sub exportWorkbook()
Dim fName As String
Dim wkb As Workbook
Dim wks As Worksheet
Dim mySht As Worksheet
Dim mySheets() As String
Dim i As Long
Dim newWkb As Workbook

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Set wkb = ThisWorkbook
    Set wks = wkb.Sheets("Data")
    
   fName = "D:\File Recovery\" & wks.Range("A1").Value & wks.Range("C4").Value & ".xls"
   'fName = ThisWorkbook.Path & "\" & wks.Range("A3").Value & wks.Range("C3").Value & ".xls"
    
    For Each mySht In ThisWorkbook.Worksheets
        If mySht.Name <> "Data" Then
            ReDim Preserve mySheets(i) As String
            mySheets(i) = mySht.Name
            i = i + 1
        End If
    Next mySht
    
    ReDim Preserve mySheets(UBound(mySheets) - 1)
    
    ThisWorkbook.Sheets(mySheets).Move
    'Call RemoveAllMacros(ActiveWorkbook) 'in case there are macros in the sheet's codepages
    ActiveWorkbook.SaveAs Filename:=fName, FileFormat:=xlExcel8
    ActiveWorkbook.Close
    
    MsgBox "Successful export of " & fName
    
    With Sheets("Data")
        .UsedRange.Offset(, 3).Clear
        .DrawingObjects.Delete
    End With
    Application.DisplayAlerts = False
    Application.ScreenUpdating = True
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Billa7Author Commented:
Hi StephenJR,

Thanks a lot for the help.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.