• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Avoiding sheets with specific names

B

Brooksy1

New Member
Hi all,

I am using some code that exports all visible sheets from a workbook into individual workbooks and saves them. What i would like to add is a list of sheet names to avoid. For example if i run the macro it would export all visible sheets except ones with the names Fred, Tom, Josh and Harry.

Its probably worth adding that the code below is a piece from a slightly bigger bit of code that selects the sheets to hide/unhide prior to exporting. I piece all of my code together from my bit of knowledge and different articles/forums but have been unable to find anything like i explain above.

Hopefully this makes sense but let me know if further explanation is required.

Code: 
'Working in 97-2013
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy

            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook

            'Determine the Excel version and file extension/format
            With Destwb
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007-2013
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        Select Case Sourcewb.FileFormat
                        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                        Case 52:
                            If .HasVBProject Then
                                FileExtStr = ".xlsm": FileFormatNum = 52
                            Else
                                FileExtStr = ".xlsx": FileFormatNum = 51
                            End If
                        Case 56: FileExtStr = ".xls": FileFormatNum = 56
                        Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                        End Select
                    End If
                End If
            End With


            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If


            'Save the new workbook and close it
            With Destwb
            Application.DisplayAlerts = False
            Application.EnableEvents = False
                .Saveas FolderName _
                      & "\" & Destwb.Sheets(1).Name, FileFormat:=xlOpenXMLWorkbook _
                        , Password:="Red", ReadOnlyRecommended:=False _
        , CreateBackup:=False
        Application.EnableEvents = True
        Application.DisplayAlerts = True
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "You can find the files in " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
 
Last edited:
You can do something like this.
Code: 
Sub Test()
Dim shtArr
Dim ws As Worksheet

shtArr = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4")

For Each ws In ThisWorkbook.Worksheets
    If IsError(Application.Match(ws.Name, shtArr, 0)) Then
        'Do something if ws.Name isn't found in array
    End If
Next ws

End Sub
 
Hi Chihiro,

Thanks for the reply. I am trying to get the above code to work and approaching it by sandwiching the save code i have above into your code as i have shown below however this brings up several errors around End If. Any other pointers would be great.
Code: 
Sub Test()
Dim shtArr
Dim ws As Worksheet

shtArr = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4")

For Each ws In ThisWorkbook.Worksheets
    If IsError(Application.Match(ws.Name, shtArr, 0)) Then
        'Do something if ws.Name isn't found in array
'Working in 97-2013
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy

            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook

            'Determine the Excel version and file extension/format
            With Destwb
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007-2013
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        Select Case Sourcewb.FileFormat
                        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                        Case 52:
                            If .HasVBProject Then
                                FileExtStr = ".xlsm": FileFormatNum = 52
                            Else
                                FileExtStr = ".xlsx": FileFormatNum = 51
                            End If
                        Case 56: FileExtStr = ".xls": FileFormatNum = 56
                        Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                        End Select
                    End If
                End If
            End With


            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If


            'Save the new workbook and close it
            With Destwb
            Application.DisplayAlerts = False
            Application.EnableEvents = False
                .Saveas FolderName _
                      & "\" & Destwb.Sheets(1).Name, FileFormat:=xlOpenXMLWorkbook _
                        , Password:="Red2017", ReadOnlyRecommended:=False _
        , CreateBackup:=False
        Application.EnableEvents = True
        Application.DisplayAlerts = True
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "You can find the files in " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
    End If
Next ws

End Sub
 
Try this.
Code: 
Sub Test()

'Working in 97-2013
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String
    Dim shtArr
   
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'Copy every sheet from the workbook with this macro
  Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName
   
    shtArr = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4")

    'Copy every visible sheet to a new workbook
  For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
      If sh.Visible = -1 And IsError(Application.Match(sh.Name, shArr, 0)) Then
            sh.Copy

            'Set Destwb to the new workbook
          Set Destwb = ActiveWorkbook

            'Determine the Excel version and file extension/format
          With Destwb
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                  FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007-2013
                  If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        Select Case Sourcewb.FileFormat
                        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                        Case 52:
                            If .HasVBProject Then
                                FileExtStr = ".xlsm": FileFormatNum = 52
                            Else
                                FileExtStr = ".xlsx": FileFormatNum = 51
                            End If
                        Case 56: FileExtStr = ".xls": FileFormatNum = 56
                        Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                        End Select
                    End If
                End If
            End With


            'Change all cells in the worksheet to values if you want
          If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If


            'Save the new workbook and close it
          With Destwb
            Application.DisplayAlerts = False
            Application.EnableEvents = False
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name, FileFormat:=xlOpenXMLWorkbook _
                        , Password:="Red2017", ReadOnlyRecommended:=False _
        , CreateBackup:=False
        Application.EnableEvents = True
        Application.DisplayAlerts = True
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "You can find the files in " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub
 
Hi Chihiro,

That has done the trick, slight adjustment i had to make is changing this

Code: 
        'If the sheet is visible then copy it to a new workbook
    If sh.Visible = -1 And IsError(Application.Match(sh.Name, shArr, 0)) Then
            sh.Copy

to this

Code: 
        'If the sheet is visible then copy it to a new workbook
    If sh.Visible = -1 And IsError(Application.Match(sh.Name, shtArr, 0)) Then
            sh.Copy

Other then that a perfect end result. Many thanks for you help, it really is appreciated.

Tom
 
You must log in or register to reply here.
Back
Top