3
\$\begingroup\$

Basically below code is taking first 7 tabs from my current sheet and pasting them as values in a blank excel sheet with same tab names and saving them in a specific folder by filename I specified. Then doing same thing for next 7 tabs and so on. It does this 5 times in total then returns to original file and unhighlights all tabs and places curser on A1 in first tab. I'm looking to trim this code.

Sub copysheets()


    Sheets(Array("Commercial-all", "Commercial-Corp", "Commercial-HS Admin", _
        "Commercial-APAC", "Commercial-EMEA", "Commercial-LAM", "Commercial-H1")).Select
    Sheets("Commercial-APAC").Activate
    Cells.Select
    Selection.Copy
    Workbooks.Add
    yolo = ActiveWorkbook.Name
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets("Sheet1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Sheets("Sheet1").Select
    Windows("Support Function P&L Details FY23-Update File.xlsm").Activate
    Application.CutCopyMode = False
    Workbooks(yolo).Activate
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = "Commercial-all"
    Sheets("Sheet2").Select
    Sheets("Sheet2").Name = "Commercial-Corp"
    Sheets("Sheet3").Select
    Sheets("Sheet3").Name = "Commercial-HS Admin"
    Sheets("Sheet4").Select
    Sheets("Sheet4").Name = "Commercial-APAC"
    Sheets("Sheet5").Select
    Sheets("Sheet5").Name = "Commercial-EMEA"
    Sheets("Sheet6").Select
    Sheets("Sheet6").Name = "Commercial-LAM"
    Sheets("Sheet7").Select
    Sheets("Sheet7").Name = "Commercial-H1"
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\Documents\GSF\Monthly extract\commercial P&L FY23 Mon.xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.Close
    Windows("Support Function P&L Details FY23-Update File.xlsm").Activate
    
'repeat
    Sheets(Array("Finance-all", "Finance-Corp", "Finance-HS Admin", _
        "Finance-APAC", "Finance-EMEA", "Finance-LAM", "Finance-H1")).Select
    Sheets("Finance-APAC").Activate
    Cells.Select
    Selection.Copy
    Workbooks.Add
    yolo = ActiveWorkbook.Name
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets("Sheet1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Sheets("Sheet1").Select
    Windows("Support Function P&L Details FY23-Update File.xlsm").Activate
    Application.CutCopyMode = False
    Workbooks(yolo).Activate
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = "Finance-all"
    Sheets("Sheet2").Select
    Sheets("Sheet2").Name = "Finance-Corp"
    Sheets("Sheet3").Select
    Sheets("Sheet3").Name = "Finance-HS Admin"
    Sheets("Sheet4").Select
    Sheets("Sheet4").Name = "Finance-APAC"
    Sheets("Sheet5").Select
    Sheets("Sheet5").Name = "Finance-EMEA"
    Sheets("Sheet6").Select
    Sheets("Sheet6").Name = "Finance-LAM"
    Sheets("Sheet7").Select
    Sheets("Sheet7").Name = "Finance-H1"
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\Documents\GSF\Monthly extract\Finance P&L FY23 Mon.xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.Close
    Windows("Support Function P&L Details FY23-Update File.xlsm").Activate
    
'repeat
        Sheets(Array("HR-all", "HR-Corp", "HR-HS Admin", _
        "HR-APAC", "HR-EMEA", "HR-LAM", "HR-H1")).Select
    Sheets("HR-APAC").Activate
    Cells.Select
    Selection.Copy
    Workbooks.Add
    yolo = ActiveWorkbook.Name
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets("Sheet1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Sheets("Sheet1").Select
    Windows("Support Function P&L Details FY23-Update File.xlsm").Activate
    Application.CutCopyMode = False
    Workbooks(yolo).Activate
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = "HR-all"
    Sheets("Sheet2").Select
    Sheets("Sheet2").Name = "HR-Corp"
    Sheets("Sheet3").Select
    Sheets("Sheet3").Name = "HR-HS Admin"
    Sheets("Sheet4").Select
    Sheets("Sheet4").Name = "HR-APAC"
    Sheets("Sheet5").Select
    Sheets("Sheet5").Name = "HR-EMEA"
    Sheets("Sheet6").Select
    Sheets("Sheet6").Name = "HR-LAM"
    Sheets("Sheet7").Select
    Sheets("Sheet7").Name = "HR-H1"
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\Documents\GSF\Monthly extract\HR P&L FY23 Mon.xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.Close
    Windows("Support Function P&L Details FY23-Update File.xlsm").Activate
  
'repeat

        Sheets(Array("IT-all", "IT-Corp", "IT-HS Admin", _
        "IT-APAC", "IT-EMEA", "IT-LAM", "IT-H1")).Select
    Sheets("IT-APAC").Activate
    Cells.Select
    Selection.Copy
    Workbooks.Add
    yolo = ActiveWorkbook.Name
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets("Sheet1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Sheets("Sheet1").Select
    Windows("Support Function P&L Details FY23-Update File.xlsm").Activate
    Application.CutCopyMode = False
    Workbooks(yolo).Activate
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = "IT-all"
    Sheets("Sheet2").Select
    Sheets("Sheet2").Name = "IT-Corp"
    Sheets("Sheet3").Select
    Sheets("Sheet3").Name = "IT-HS Admin"
    Sheets("Sheet4").Select
    Sheets("Sheet4").Name = "IT-APAC"
    Sheets("Sheet5").Select
    Sheets("Sheet5").Name = "IT-EMEA"
    Sheets("Sheet6").Select
    Sheets("Sheet6").Name = "IT-LAM"
    Sheets("Sheet7").Select
    Sheets("Sheet7").Name = "IT-H1"
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\Documents\GSF\Monthly extract\IT P&L FY23 Mon.xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.Close
    Windows("Support Function P&L Details FY23-Update File.xlsm").Activate
    
'repeat

    Sheets(Array("Legal-all", "Legal-Corp", "Legal-HS Admin", _
        "Legal-APAC", "Legal-EMEA", "Legal-LAM", "Legal-H1")).Select
    Sheets("Legal-APAC").Activate
    Cells.Select
    Selection.Copy
    Workbooks.Add
    yolo = ActiveWorkbook.Name
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets("Sheet1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Sheets("Sheet1").Select
    Windows("Support Function P&L Details FY23-Update File.xlsm").Activate
    Application.CutCopyMode = False
    Workbooks(yolo).Activate
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = "Legal-all"
    Sheets("Sheet2").Select
    Sheets("Sheet2").Name = "Legal-Corp"
    Sheets("Sheet3").Select
    Sheets("Sheet3").Name = "Legal-HS Admin"
    Sheets("Sheet4").Select
    Sheets("Sheet4").Name = "Legal-APAC"
    Sheets("Sheet5").Select
    Sheets("Sheet5").Name = "Legal-EMEA"
    Sheets("Sheet6").Select
    Sheets("Sheet6").Name = "Legal-LAM"
    Sheets("Sheet7").Select
    Sheets("Sheet7").Name = "Legal-H1"
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\Documents\GSF\Monthly extract\Legal P&L FY23 Mon.xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.Close
    
'go back to support function P&L
    Windows("Support Function P&L Details FY23-Update File.xlsm").Activate
    Sheets("Copy button").Activate
End Sub
\$\endgroup\$
1

1 Answer 1

3
\$\begingroup\$

Copy Series of Sheets To New Workbooks

Option Explicit
' Use 'Option Explicit' which will force you to declare all variables
' but will benefit you on multiple accounts e.g. by detecting typos
' at compile-time (before running the code (run-time)).
' Use variables to make the code more readable e.g. to avoid unecessary
' repeating code and long unreadable lines.

Sub ExtractMonthly() ' Use a more appropriate name for the procedure.
    
    ' Define constants.
    
    ' Use constants at the beginning of the code so you can easily modify
    ' them instead of looking for them scattered in the code.
    Const PROC_TITLE As String = "Extract Monthly"
    Const SRC_NAME As String = "Copy Button"
    Const SRC_FINAL_CELL As String = "A1"
    Const DST_PARENT_FOLDER_PATH As String = "C:\Users\"
    Const DST_SUBFOLDER_PATH As String = "Documents\GSF\Monthly extract\"
    Const DST_FILE_NAME_SUFFIX As String = " P&L FY23 Mon"
    Const psDelimiter As String = "-"
    
    ' Use arrays so you can easily combine data by using a loop.
    Dim Prefixes(): Prefixes = VBA.Array( _
        "Commercial", "Finance", "HR", "IT", "Legal")
    Dim Suffixes(): Suffixes = VBA.Array( _
        "all", "Corp", "HS Admin", "APAC", "EMEA", "LAM", "H1")
    ' The 'VBA.' preceding 'Array' will ensure a zero-based array
    ' ('Option Base'-related).
    
    ' Determine the Destination path.
    
    Dim pSep As String: pSep = Application.PathSeparator
    
    ' Check the path separators.
    Dim dpPath As String: dpPath = DST_PARENT_FOLDER_PATH
    If Right(dpPath, 1) <> pSep Then dpPath = dpPath & pSep
    Dim dsPath As String: dsPath = DST_SUBFOLDER_PATH
    If Left(dsPath, 1) = pSep Then dsPath = Right(dsPath, Len(dsPath) - 1)
    If Right(dsPath, 1) <> pSep Then dsPath = dsPath & pSep
    Dim dPath As String: dPath = dpPath & dsPath
    
    ' Usually, the 'Documents' folder is located in one of the following
    ' two locations: 'Environ("USERPROFILE")' or 'Environ("OneDrive")'.
    If Len(Dir(dPath, vbDirectory)) = 0 Then
        dPath = Environ("USERPROFILE") & pSep & DST_SUBFOLDER_PATH
        If Len(Dir(dPath, vbDirectory)) = 0 Then
            dPath = Environ("OneDrive") & pSep & DST_SUBFOLDER_PATH
            If Len(Dir(dPath, vbDirectory)) = 0 Then
                MsgBox "Could not find the destination path.", _
                    vbCritical, PROC_TITLE
                Exit Sub
            End If
        End If
    End If
    
    ' Prepare the rest for the loop.
    
    ' Retrieve the upper limits of the given arrays.
    Dim pUpper As Long: pUpper = UBound(Prefixes)
    Dim sUpper As Long: sUpper = UBound(Suffixes)
    ' Define the SheetNames array.
    Dim SheetNames() As String: ReDim SheetNames(0 To sUpper)
    ' Reference the Source workbook.
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
    ' Only if the code is not in the source workbook, use:
    'Set swb = Workbooks("Support Function P&L Details FY23-Update File.xlsm")
    ' The benefit of using 'ThisWorkbook' is that you can use this code
    ' in any workbook and if you rename the workbook, the code will still work.
    
    ' Right before the loop, is often the best place to turn off screen updating
    ' which may or may not increase efficiency but will certainly prevent
    ' screen flickering especially in this case with all
    ' the 'copy-to-new-workbook' activity.

    Application.ScreenUpdating = False
    
    ' Declare variables to be used in the loop.
    Dim dwb As Workbook, dws As Worksheet
    Dim p As Long, s As Long, Prefix As String, dBaseName As String
    
    ' The Loop
    
    For p = 0 To pUpper
        
        ' Write the sheet names to the array.
        
        Prefix = Prefixes(p)
        
        For s = 0 To sUpper
            SheetNames(s) = Prefix & psDelimiter & Suffixes(s)
        Next s
        ' When using an array of sheet names to copy sheets to a new workbook
        ' in one go, the sheets are copied in the order as they appear
        ' in the workbook, which is not necessarily the order in the array.
        ' At least one of the sheets needs to be visible. Hidden sheets
        ' will be copied hidden while very hidden sheets will be skipped
        ' without warning.
        
        ' Copy the sheets to a new workbook, convert to values,
        ' save and close the new workbook.
        
        swb.Sheets(SheetNames).Copy
        Set dwb = Workbooks(Workbooks.Count)
        For Each dws In dwb.Worksheets
            ' Convert to values while preserving formatting.
            dws.UsedRange.Value = dws.UsedRange.Value
        Next dws
        ' When saving a never saved workbook, it will by default be saved
        ' as a macro-free workbook ('.xlsx'), so there is no need
        ' for the file extension nor the 'FileFormat' parameter.
        dBaseName = dPath & Prefix & DST_FILE_NAME_SUFFIX
        ' Disable alerts to remove any code from the object modules,
        ' and to overwrite an existing file, both without confirmation.
        Application.DisplayAlerts = False
            dwb.SaveAs dBaseName
        Application.DisplayAlerts = True
        dwb.Close SaveChanges:=False ' it just got saved
        
    Next p ' next prefix, next 's' number of worksheets, next workbook

    ' Finishing Touches

    ' You don't want to activate or select anything unless necessary
    ' because it messes up the selection and severly slows down the code.
    ' If you run this code from a button on the 'Copy Button' sheet,
    ' since you have closed all newly created workbooks, most likely
    ' the 'Copy Button' worksheet will be the active (selected) one.
    ' Just in case it isn't (when running the code while another workbook
    ' or worksheet is active), you can use the following:
    If Not swb Is ActiveWorkbook Then swb.Activate
    Dim sws As Worksheet: Set sws = swb.Sheets(SRC_NAME)
    Application.Goto sws.Range(SRC_FINAL_CELL) ' sheet selection included
    ' i.e. you need to make sure the correct workbook is active to select
    ' a sheet in it, and you need to make sure that the correct worksheet
    ' is selected (active) to select a cell (range) in it. For the latter,
    ' alternatively, you can use `Application.Goto`.
    
    ' Right before the message box showing, is often the best place
    ' to turn screen updating back on so you can already see any changes
    ' while the message box is showing. Of course, in this case, you will
    ' just be seeing the 'Copy Button' worksheet but it's good practice.
    Application.ScreenUpdating = True
    
    ' Using a message box at the end of the code is also good practice
    ' so you know the code has run especially when the code would
    ' do harm when running again. In this case, if you would accidentally
    ' run the code again, it would just overwrite the previously created files
    ' with the same files but would waste your precious time.
    MsgBox "Monthly data extracted.", vbInformation, PROC_TITLE
    
End Sub
\$\endgroup\$
1
  • \$\begingroup\$ thanks the code and explanation ... quick follow up question. The copy paste part I need it to be exactly paste formats followed by paste values and number formats. Reason is excel is pulling up numbers from an external source with formulas and thats the only way to ensure values are copied and pasted properly. How would I incorporate that into this part of the code? dws.UsedRange.Value = dws.UsedRange.Value \$\endgroup\$
    – Sorab
    Jan 30, 2023 at 16:35

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.