Macro to copy listed sheets to a new file and save at same directory

[manekankit]

Need help with macro to perform following task.

1. I have a file (Original file) with 6 sheets (Index, Report1, Report2, Report3, Report4 and Data)
2. Report1, 2, 3 and 4 sheets are linked through formulas to 'Data' sheet
3. Colum A in Index sheet contain list of sheets to be copied to a new book (e.g. it contains Report1, Report2 and Data in cells A1, A2 and A3 respectively). This list can increase or decrease.

Required:
1. Copy sheets listed in column A of Index sheet to a new workbook.
2. Save that new workbook with pre-defined name say'NewWB.xlsx'.
3. File should be saved to Original file path > Export > mmddyy (i.e. in the same path it should create 'Export' folder and in 'Export' folder it should create folder with dynamic name based on date(mmddyy) (eg. 11272022 for today) and file should be saved in this ddmmyy folder
4. Newly copied file should have pre-defined password ("ABC123").

Further my 'Data' sheet contains a table. If I manually move say Report1, Report2 and Data sheet, excel does not allow to move them together to a new sheet as 'Data' sheet contains a table. I have to move them all reports that i want to move first and then data file. New file should be such that formulas in Rport1, 2 etc. sheets are linked to 'Data' sheet in the new file itself.

Request you to help with macro code.

 

[breynolds0431]

Hello. Give the below a try. It, including the two functions, should be added to a normal module. Let me know if you run into any problems or have any questions.

Sub CopySheets()

On Error GoTo Reset

'Turns screen updating off (turns back on at end of code)
Application.ScreenUpdating = False

Dim wb As Workbook: Set wb = ThisWorkbook
'declares index sheet
Dim indWS As Worksheet: Set indWS = wb.Sheets("Index")
'declares data sheet
Dim dataWS As Worksheet: Set dataWS = wb.Sheets("Data")
'sets range with lists of sheet names to copy
Dim indRNG As Range: Set indRNG = indWS.Range("A1:A" & indWS.Cells(indWS.Rows.Count, 1).End(xlUp).Row)

'Temporarily unlists table in Data tab so it can be copied with other sheets
'**Ensure part of your table is in range A4. If not update A4 to a cell within table
Dim tblNm As String: tblNm = dataWS.Range("A4").ListObject.Name
Dim LO As ListObject: Set LO = dataWS.ListObjects(tblNm)
LO.Unlist

'Creates folders
Dim fPath As String: fPath = wb.Path
Dim nFold As String: nFold = fPath & "/" & "Export"
'Checks if Export folder exists; if not, it will be created
If FolderExist(nFold) = False Then
    MkDir nFold
End If
'Checks if current date folder exists; if not, it will be created
Dim tFold As String: tFold = nFold & "/" & Format(Date, "mmddyy")
If FolderExist(tFold) = False Then
    MkDir tFold
End If

'Groups sheets from Index tab into an array and copies to a new book
Dim shtString As String: shtString = RangeToString(indRNG)
Dim shtArr As Variant: shtArr = shtString
Sheets(Split(shtArr, ",")).Copy

'declares new workbook
Dim nWB As Workbook: Set nWB = ActiveWorkbook
'sets new workbook's name
Dim nWBName As String: nWBName = "NewWB"
'sets new workbook's password
Dim nWBPW As String: nWBPW = "ABC123"
'Restores Data tab with table and saves the new workbook
With nWB
    .Sheets("Data").ListObjects.Add(xlSrcRange, .Sheets("Data").UsedRange, , xlYes).Name = tblNm
    .SaveAs Filename:=tFold & "/" & nWBName & ".xlsx", Password:=nWBPW
    '.Close 'Unsure if you want the new workbook to remain open
End With

'Recreates table in the source Data tab
With wb.Sheets("Data")
    .ListObjects.Add(xlSrcRange, .UsedRange, , xlYes).Name = tblNm
End With

'Turns screen updating back on
Application.ScreenUpdating = True

Exit Sub
'Error handling
Reset:
MsgBox "Error # " & Str(Err.Number) & " was generated by " _
            & Err.Source & Chr(13) & Chr(13) & Err.Description, _
            vbMsgBoxHelpButton, "Error", Err.HelpFile, Err.HelpContext
Application.ScreenUpdating = True

End Sub

Function RangeToString(ByVal myRange As Range) As String
    RangeToString = ""
    If Not myRange Is Nothing Then
        Dim myCell As Range
        For Each myCell In myRange
            RangeToString = RangeToString & "," & myCell.Value
        Next myCell
        'Remove extra comma
        RangeToString = Right(RangeToString, Len(RangeToString) - 1)
    End If
End Function

Function FolderExist(folderPath) As Boolean
    FolderExist = Dir(folderPath, vbDirectory) <> ""
End Function