• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 359
  • Last Modified:

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
0
Billa7
Asked:
Billa7
  • 2
  • 2
1 Solution
 
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
 
Billa7Author Commented:
Hi StephenJR,

Thanks a lot for the help.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now