I have been working on my code to get the system to export specific sheet based only on what is visible in the system yet, for some reason I continue to struggle when it is trying to run the export with getting only the specified sheets to export. I know this has to be something simple that I am missing but I am unable to locate what that might be. Any assistance would be greatly appreciated.
Private Sub ExportSheets() 'saves all visible sheets as new xlsx files
Dim ws As Worksheet, wbNew As Workbook
Dim myWorksheets() As String 'Array to hold worksheet names to copy
Dim sFolderPath As String
Dim fs As Object
Dim FileName1 As String
Dim i As Integer
Set wbNew = Application.ThisWorkbook
FileName1 = Range("PMC_Name").Value
sFolderPath = wbNew.Path & "\" & FileName1 & " - Import Templates"
myWorksheets = Split("Chart of Accounts, Custom Mapping File, Custom Chart of Accounts,Conventional Default COA,Conventional Mapping File,CONV Chart of Accounts,HUD Chart of Accounts,Affordable Default COA,Affordable Mapping File,Entities,Properties,Floors,Units,Area Measurement,Tenants,Account Labels,Leases,Scheduled Charges,Tenant Beginning Balances,Vendors,Vendor Beginning Balances,Customers,Customer Beginning Balances,GL Beginning Balances,GL Detail,Bank Accounts,Budgets,Budgeting COA,Budgeting Conventional COA,Budgeting Affordable COA,Budgeting Job Positions,Budgeting Employee List,Budgeting Workers Comp,Expense Pools,Lease Recoveries,Index Code,Lease Sales,Option Types,Clause Types,Lease Clauses,Lease Options,Budgeting Current Budget Import,Job Cost,Draw Model Detail,Job Cost History,Job Cost Budgets,Fixed Assets,Condo Properties,Owners,Ownership Information,Ownership Billing,Owner Charges", ",") 'this contains an array of the sheets. You need to put the real sheet names here.
If Dir(sFolderPath, vbDirectory) <> "" Then
'If the folder does exist error
MsgBox "The folder currently exists, please rename or delete the folder.", vbCritical, "Error"
Exit Sub
'If the folder does not exist create folder and export
End If
MkDir sFolderPath
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Sheets 'for each worksheet
'if it's visible:
If Sheets(myWorksheets(i)).visible Then
Debug.Print "Exporting: " & ws.Name
ws.Copy '(if no params specified, COPY creates + activates a new wb)
Set wbNew = Application.ActiveWorkbook 'get new wb object
wbNew.SaveAs sFolderPath & "\" & ws.Name & ".csv", 23 'save new wb
wbNew.Close 'close new wb
Set wbNew = Nothing 'cleanup
End If
Next ws
Set ws = Nothing 'clean up
Application.ScreenUpdating = False
MsgBox "Sheet Export is now Complete. You can find the files at the following path." & vbNewLine & vbNewLine & sFolderPath, vbExclamation, "Export Sheets Complete"
End Sub
Sub ExportSheets() 'saves all visible sheets as new xlsx files
Const PROC_TITLE As String = "Export Sheets"
Const SHEET_LIST As String _
= "Chart of Accounts,Custom Mapping File,Custom Chart of Accounts," _
& "Conventional Default COA,Conventional Mapping File," _
& "CONV Chart of Accounts,HUD Chart of Accounts," _
& "Affordable Default COA,Affordable Mapping File,Entities," _
& "Properties,Floors,Units,Area Measurement,Tenants,Account Labels," _
& "Leases,Scheduled Charges,Tenant Beginning Balances,Vendors," _
& "Vendor Beginning Balances,Customers,Customer Beginning Balances," _
& "GL Beginning Balances,GL Detail,Bank Accounts,Budgets," _
& "Budgeting COA,Budgeting Conventional COA,Budgeting Affordable COA," _
& "Budgeting Job Positions,Budgeting Employee List," _
& "Budgeting Workers Comp,Expense Pools,Lease Recoveries,Index Code," _
& "Lease Sales,Option Types,Clause Types,Lease Clauses,Lease Options," _
& "Budgeting Current Budget Import,Job Cost,Draw Model Detail," _
& "Job Cost History,Job Cost Budgets,Fixed Assets,Condo Properties," _
& "Owners,Ownership Information,Ownership Billing,Owner Charges"
Dim swb As Workbook: Set swb = ThisWorkbook
Dim sws As Worksheet: Set sws = swb.Sheets("Sheet1") ' adjust!
Dim PMC As String: PMC = CStr(sws.Range("PMC_Name").Value)
Dim dFolderPath As String
dFolderPath = swb.Path & "\" & PMC & " - Import Templates\"
If Len(Dir(dFolderPath, vbDirectory)) > 0 Then
MsgBox "The folder already exists. " _
& "Please rename or delete the folder.", vbCritical, PROC_TITLE
Exit Sub
End If
MkDir dFolderPath
Dim SheetNames() As String: SheetNames = Split(SHEET_LIST, ",")
Application.ScreenUpdating = False
Dim dwb As Workbook, ssh As Object, SheetName
For Each SheetName In SheetNames
On Error Resume Next
Set ssh = swb.Sheets(SheetName)
On Error GoTo 0
If Not ssh Is Nothing Then ' sheet exists
If ssh.Visible Then ' sheet is visible
Debug.Print "Exporting: " & ssh.Name
ssh.Copy ' creates a single-sheet workbook
Set dwb = Workbooks(Workbooks.Count)
dwb.SaveAs dFolderPath & ssh.Name & ".csv", xlCSVWindows ' 23
dwb.Close SaveChanges:=False
'Else ' sheet is not visible; do nothing
End If
Set ssh = Nothing ' reset for the next iteration
'Else ' sheet doesn't exist; do nothing
End If
Next SheetName
Application.ScreenUpdating = True
MsgBox "Sheet Export is now complete. " _
& "You can find the files in the following path:" & vbLf & vbLf _
& dFolderPath, vbInformation, PROC_TITLE
End Sub