My loop is not using only selected sheets

Question

I have this code a have changed and added to. At the moment it takes all sheets and renames them with cell B1, creates a folder named after the workbook plus date and time (in the same place as the workbook is saved). Saves all sheets as independent sheets in the folder.

What I need it to do and am having trouble with is.

Creates a folder named after the workbook only. Takes all sheets and renames them with cell B1, Works well. Select only sheets needed. (The code for this works on its own but not as part of this code nor as a module ran at the same time.)

Dim Sheet(4 To 18) As String
If Sheets(4).Visible = True Then
    Sheets(Array(3, 4)).Select
End If
If Sheets(5).Visible = True Then
    Sheets(Array(3, 4, 5)).Select
End If
If Sheets(6).Visible = True Then
    Sheets(Array(3, 4, 5, 6)).Select
End If
If Sheets(7).Visible = True Then
    Sheets(Array(3, 4, 5, 6, 7)).Select
End If
If Sheets(8).Visible = True Then
    Sheets(Array(3, 4, 5, 6, 7, 8)).Select
End If
If Sheets(9).Visible = True Then
    Sheets(Array(3, 4, 5, 6, 7, 8, 9)).Select
End If
If Sheets(10).Visible = True Then
    Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10)).Select
End If
If Sheets(11).Visible = True Then
    Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10, 11)).Select
End If
If Sheets(12).Visible = True Then
    Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12)).Select
End If
If Sheets(13).Visible = True Then
    Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13)).Select
End If
If Sheets(14).Visible = True Then
    Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14)).Select
End If
If Sheets(15).Visible = True Then
    Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15)).Select
End If
If Sheets(16).Visible = True Then
    Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16)).Select
End If
If Sheets(17).Visible = True Then
    Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17)).Select
End If
If Sheets(18).Visible = True Then
    Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18)).Select
End If

Saves all selected sheets as independent sheets in the folder. Here is the code all together

Sub allin()
    Dim Sheet(4 To 18) As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim xWs As Worksheet
    Dim xWb As Workbook
    Dim xNWb As Workbook
    Dim FolderName As String
    Application.ScreenUpdating = False
    Set xWb = Application.ThisWorkbook
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
    If Sheets(4).Visible = True Then
        Sheets(Array(3, 4)).Select
    End If
    If Sheets(5).Visible = True Then
        Sheets(Array(3, 4, 5)).Select
    End If
    If Sheets(6).Visible = True Then
        Sheets(Array(3, 4, 5, 6)).Select
    End If
    If Sheets(7).Visible = True Then
        Sheets(Array(3, 4, 5, 6, 7)).Select
    End If
    If Sheets(8).Visible = True Then
        Sheets(Array(3, 4, 5, 6, 7, 8)).Select
    End If
    If Sheets(9).Visible = True Then
        Sheets(Array(3, 4, 5, 6, 7, 8, 9)).Select
    End If
    If Sheets(10).Visible = True Then
        Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10)).Select
    End If
    If Sheets(11).Visible = True Then
        Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10, 11)).Select
    End If
    If Sheets(12).Visible = True Then
        Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12)).Select
    End If
    If Sheets(13).Visible = True Then
        Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13)).Select
    End If
    If Sheets(14).Visible = True Then
        Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14)).Select
    End If
    If Sheets(15).Visible = True Then
        Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15)).Select
    End If
    If Sheets(16).Visible = True Then
        Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16)).Select
    End If
    If Sheets(17).Visible = True Then
        Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17)).Select
    End If
    If Sheets(18).Visible = True Then
        Sheets(Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18)).Select
    End If
    For Each xWs In Sheets
        xWs.Name = xWs.Range("B1")
    Next xWs
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        Select Case xWb.FileFormat
            Case 51:
                FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If Application.ActiveWorkbook.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
    MkDir FolderName
    For Each xWs In xWb.Worksheets
        On Error GoTo NErro
        If xWs.Visible = xlSheetVisible Then
            xWs.Activate
            xWs.Select
            xWs.Copy
            xFile = FolderName & "\" & xWs.Name & FileExtStr
            Set xNWb = Application.Workbooks.Item(Application.Workbooks.Count)
            xNWb.SaveAs xFile, FileFormat:=FileFormatNum
            xNWb.Close False, xFile
        End If
NErro:
        xWb.Activate
    Next
    MsgBox "All Done!"
End Sub

Siddharth Rout · Accepted Answer · 2021-07-23T08:11:58.183

Avoid the use of .Select. You may want to read up on How to avoid using Select in Excel VBA

Is this what you are trying? I have commented the code so you should not have a problem understanding it. But if you do, then simply ask.

Option Explicit

Dim FolderPath As String
Dim FileFormatNum  As Integer
Dim FileExtStr As String
    
Sub Sample()
    Dim i As Long
    Dim DateString As String
    Dim wbName As String
    
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        Select Case ThisWorkbook.FileFormat
            Case 51:
                FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If Application.ActiveWorkbook.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

    '~~> Get file name without extension
    wbName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1))
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    '~~> Final folder path
    FolderPath = ThisWorkbook.Path & "\" & wbName & " " & DateString
    
    '~~> Check if folder exists. If it doesn't then create it
    If Not FolderExists(FolderPath) Then MkDir FolderPath
    
    '~~> Loop through the worksheets and save them
    For i = 4 To 18
        If ThisWorkbook.Sheets(i).Visible Then
            RenameAndSaveSheet ThisWorkbook.Sheets(i)
        End If
    Next i
End Sub

Private Sub RenameAndSaveSheet(ws As Worksheet)
    Dim FlName As String
    Dim wbNew As Workbook

    With ws
        .Copy
        .Name = .Range("B1").Value2
        
        FlName = FolderPath & "\" & ws.Name & FileExtStr
        
        Set wbNew = Application.Workbooks.Item(Application.Workbooks.Count)
        wbNew.SaveAs FlName, FileFormat:=FileFormatNum
        wbNew.Close False
    End With
End Sub

'~~> Function to check if folder exists
Private Function FolderExists(strFullPath As String) As Boolean
    On Error GoTo EarlyExit
    If Not Dir(strFullPath, vbDirectory) = vbNullString Then FolderExists = True
EarlyExit:
    On Error GoTo 0
End Function

IN ACTION

Pᴇʜ · Answer 2 · 2021-07-23T07:52:07.177

First reduce that massive If repetition with loops:

Dim iSheet As Long
For iSheet = 18 To 4 Step -1
    If Sheets(iSheet).Visible Then
        Dim Arr() As Variant
        ReDim Arr(iSheet - 3)

        Dim iArr As Long
        For iArr = 0 To iSheet - 3
            Arr(iArr) = iArr + 3
        Next iArr
        
        Exit For
    End If
Next iSheet

Then if you loop over Sheets it loops through all sheets instead you need to loop only through the sheets in your array:

For Each xWs In Sheets(Arr)
    xWs.Name = xWs.Range("B1")
Next xWs

My loop is not using only selected sheets

2 Answers2