Save a specific sheet in a new workbook

[sofas]

Hello. I have a workbook that contains several sheets. I would like to copy Sheets(main) sheet into a separate workbook and save it inside a folder that is automatically created if it does not exist, named (Report 2024) in the same path as the main workbook.

 

[bobsan42]

try this:

Sub copyMain()
    Const shtName As String = "Sheets(main)"
    Const subFolderName As String = "Report 2024"
    Const newFileName As String = "reportFile"
   
    Dim newWb As Workbook, wb As Workbook
    Dim idx As Long, fPath As String
   
    Set wb = ThisWorkbook
    idx = Application.Workbooks.Count
    wb.Worksheets(shtName).Copy
    Set newWb = Application.Workbooks(idx + 1)
    fPath = TrailingSlash(TrailingSlash(wb.Path) & subFolderName)
    If FolderExists(fPath, True) Then
        newWb.SaveAs fPath & newFileName, xlWorkbookDefault
    End If
    Set newWb = Nothing
    Set wb = Nothing
End Sub

Public Function TrailingSlash(varIn As Variant) As String
    'The TrailingSlash() function just ensures that _
    the folder names we are processing end with the slash character.

    If Len(varIn) > 0& Then
        If Right$(varIn, 1&) = Application.PathSeparator _
                Then TrailingSlash = varIn _
                Else TrailingSlash = varIn & Application.PathSeparator
    End If

End Function

Function FolderExists(ByVal strFolderName As String, Optional ForceMakeDir As Boolean = False) As Boolean
    Dim fso As New FileSystemObject
    FolderExists = fso.FolderExists(strFolderName)
       
    On Error Resume Next
    If ForceMakeDir And (Not FolderExists) Then
        fso.CreateFolder (strFolderName)
        FolderExists = fso.FolderExists(strFolderName)
       
        If Not FolderExists Then
            Dim i As Long, x As String, y
            If strFolderName Like "?:\*" Then
                x = Left(strFolderName, 3)
                y = Split(Mid(strFolderName, 4), Application.PathSeparator)
            ElseIf strFolderName Like "\\*" Then
                x = Left(strFolderName, 2)
                y = Split(Mid(strFolderName, 3), Application.PathSeparator)
            Else
                x = ""
                y = Null
            End If
       
            If (x <> "") And IsArray(y) Then
                For i = LBound(y) To UBound(y)
                    x = TrailingSlash(x) & y(i)
                    If Not FolderExists(x, True) Then Exit For
                Next i
            End If
            FolderExists = fso.FolderExists(strFolderName) 'Dir(strFolderName, vbDirectory) <> ""
        End If
       
        y = Null
    End If
    Set fso = Nothing
   
End Function