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
Export Sheets
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
I use the code below to create and open a folder from excel when I press a button but I want the created folder to be in the same location like the excel workbook. Can you please help me modif the code? Thank you!
Sub btn1_click()
Dim dir As String
Dim fso As Object
Dim path As String
path = Application.ActiveWorkbook.path
dir = ActiveCell.value
Set fso = CreateObject("scripting.filesystemobject")
If Not fso.folderexists(dir) Then
fso.createfolder (dir)
End If
Call Shell("explorer.exe" & " " & dir, vbNormalFocus)
End Sub
Create and Explore a Subfolder Using the Active Cell's Value
The code is written for any active cell so be a little careful how you use it to not end up with folders in the wrong places.
If you run it by using a button, you are ensuring that it will use the right cell since the active sheet is the one containing the button and containing the active cell.
Sub CreateActiveCellSubFolder()
Const ExploreIfSubFolderExists As Boolean = True
Dim ash As Object: Set ash = ActiveSheet ' it could be a chart
If ash Is Nothing Then ' no active sheet
MsgBox "No visible workbooks open.", _
vbCritical
Exit Sub
End If
If ash.Type <> xlWorksheet Then
MsgBox "The active sheet '" & ash.Name & "' is not a worksheet.", _
vbCritical
Exit Sub
End If
Dim wb As Workbook: Set wb = ash.Parent
If Len(wb.Path) = 0 Then
MsgBox "The workbook '" & wb.Name & "' containing the active sheet '" _
& ash.Name & "' has not been saved yet.", _
vbCritical
Exit Sub
End If
' If the active sheet is a worksheet, it has an active cell at any time,
' no matter what is selected.
Dim aCell As Range: Set aCell = ActiveCell
Dim SubFolderName As String: SubFolderName = CStr(ActiveCell.Value)
If Len(SubFolderName) = 0 Then
MsgBox "The cell '" & aCell.Address(0, 0) & "' is blank.", _
vbCritical
Exit Sub
End If
Dim SubFolderPath As String
SubFolderPath = wb.Path & Application.PathSeparator & SubFolderName
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(SubFolderPath) Then
MsgBox "The folder '" & SubFolderName & "' already exists.", _
vbInformation
If Not ExploreIfSubFolderExists Then Exit Sub
Else
Dim ErrNum As Long
On Error Resume Next
fso.CreateFolder SubFolderPath
ErrNum = Err.Number
' If ErrNum > 0 Then
' Debug.Print "Run-time error '" & Err.Number & "': " _
' & Err.Description
' End If
On Error GoTo 0
If ErrNum = 0 Then
MsgBox "Created the folder '" & SubFolderName & "'.", _
vbInformation
Else
MsgBox "Could not create the folder '" & SubFolderName & "'.", _
vbCritical
Exit Sub
End If
End If
wb.FollowHyperlink SubFolderPath
End Sub
I want to copy the data from a closed file I have selected and see it in the file containing this macro.
I am using Office365.
How can i copy data from this "FullPath" workbook ?
Private Sub PathName()
Dim FullPath As String
On Error GoTo extApp
FullPath = Application.GetOpenFilename(FileFilter:="File Filter," & _
"*.xls;*.doc;*.xlsx;*.mdb;*.ppt;*.pdf", Title:="Please Select A File")
Exit Sub
extApp: Select Case Err.Number
Case 104
MsgBox ("104")
Exit Sub
Case Else
MsgBox "Runtime Error: " & Err.Number & vbNewLine & Err.Description
Stop
Resume
End Select
End Sub
You may try the following code modication, add in your other part of code to make it work as a complete sub:
Private Sub PathName()
Dim FullPath As String
Dim wb As Workbook
Application.DisplayAlerts = False
On Error GoTo extApp
FullPath = Application.GetOpenFilename(FileFilter:="File Filter," & _
"*.xls;*.doc;*.xlsx;*.mdb;*.ppt;*.pdf", Title:="Please Select A File")
Set wb = Workbooks.Open(FullPath, , True)
wb.Worksheets("Sheet1").Range("A1:B" & lastrow).Copy
Sheet1.Range("A1").PasteSpecial xlPasteValues
'
'
'
wb.Close
Application.DisplayAlerts = True
End Sub
I run VBA code in Access and update an existing Excel file.
I have to create xls files for each sales person and update the cells by grouping customer of monthly sales point by exporting data from an Access accdb file which is connected to Oracle database by ODBC driver.
We have about 50 sales persons and will have to create 2 files on each. If I can not fix the problem I will have 100 Excel processes on my PC. It might be frozen when run even if I successfully run the accdb with VBA.
Problems:
Can not close Excel process by Application.Quit which I tried to
open a xls file by Excel.Application.Workbooks object and it seems
be it's caught the xls file still even I used .Close
SaveChanges:=True
Can not process the VBA code again against same file cause of the
previous excel file operation process is left which I confirmed it
on task manager that I have to kill the process manually every time.
I googled on the internet and MSDN site. I could not find any good solution.
Option Compare Database
Const TARGET_SHEET = "SalesObjectiveSheet"
Const FILE_CREATION_WORK_FOLDER As String = "Work"
Const DESTINATION_ROOTPATH As String = "C:\Users\Administrator\Desktop"
Const TARGET_SHEET2 As String = "SalesObjectivesSheet"
Const HEADING_LINE_POSITION As Integer = 3
Public objApp As Excel.Application
Public objBooks As Excel.Workbooks
Public objBook As Excel.Workbook
Public objSheets As Excel.Worksheets
Public objSheet As Excel.Worksheet
Public Sub test200()
Dim str As Boolean
On Error GoTo Err_Handler
strSalesName = "SalesName"
strSalesOffice = "Tokyo"
strTargetFolder = DESTINATION_ROOTPATH & "\" & FILE_CREATION_WORK_FOLDER
strTargetFileName = "SalesObjectiveSheet_201708.xlsx"
strTargetFullPath = strTargetFolder & "\" & strTargetFileName
Set objApp = CreateObject("Excel.Application")
Set objBook = objApp.Workbooks.Open(strTargetFullPath)
Set objSheet = objBook.Worksheets(TARGET_SHEET2)
If EditObjectSheetHeader(objSheet, objApp, objBook, _
objBooks, strSalesName, strSalesOffice, strTargetFileName) = False Then
GoTo Err_Handler
End If
Exit_Handler:
objApp.Quit
Set objSheet = Nothing
Set objBooks = Nothing
Set objApp = Nothing
Exit Sub
Err_Handler:
' SysCmd acSysCmdRemoveMeter
Resume Exit_Handler
End Sub
Function EditObjectSheetHeader(objSheet As Object, objApp As Object, objBook As Object, _
objBooks As Object, strSalesName, strSalesOffice, strTargetFileName) As Boolean
Dim strProcedureName As String
Dim strMonth As String
On Error GoTo Err_Handler
objSheet.Select
objSheet.Activate
strProcedureName = "EditObjectSheetHeader"
EditObjectSheetHeader = False
With objSheet.PageSetup
.CenterHeader = "&14 " & "Month Sales Objectives"
.RightHeader = "" & Chr(10) & "Sales Office:" & strSalesOffice & " Name:" & strSalesName
.CenterFooter = "&P/&N"
.PrintTitleRows = "$1:$" & HEADING_LINE_POSITION
.LeftHeader = ""
End With
Exit_Handler:
Workbooks(strTargetFileName).Close SaveChanges:=True
' Frozen after I run the VBA code once cause of previous & _
process use same file is existed it seems be.
' ActiveWorkbook.Close saveChanges:=True
' Frozen after I run the VBA code once cause of & _
previous process use same file is existed & _
(Object and With is not defined error)
' objBook.Close SaveChanges:=True
' Frozen after I run the VBA code once cause of & _
previous process use same file is existed & _
it seems be.
' ActiveWorkbook.Close SaveChanges:=True
' Error unknown.
' ThisWorkbook.Save
'Error 1004 unknown.
EditObjectSheetHeader = True
Exit Function
Err_Handler:
Select Case Err.Number
Case 9
Debug.Print strProcedureName, Err.Number, Err.Description
MsgBox Err.Description & " " & Err.Number, vbOKOnly, strProcedureName
Case 70
Debug.Print strProcedureName, Err.Number, Err.Description
MsgBox Err.Description & " " & Err.Number, vbOKOnly, strProcedureName
Resume
Case Else
Debug.Print strProcedureName, Err.Number, Err.Description
MsgBox Err.Description & " " & Err.Number, vbExclamation, strProcedureName
End Select
End Function
Below line helped, but any other opened xls also will be closed:
Shell "taskkill /F /IM EXCEL.EXE /T"
Try placing objApp.Quit after releasing references.
Set objSheet = Nothing
Set objBooks = Nothing
Set objApp = Nothing
If Not objApp is Nothing Then objApp.Quit
I'm using the following code to save an updated workbook.
Private Sub cmdSaveUpdatedWB_Click()
On Error GoTo Err_cmdSaveUpdatedWB_Click
gwbTarget.Activate <<<<<<<<<<<<<<<<<<<<<<<
Application.DisplayAlerts = False
gwbTarget.SaveAs txtUpdWorkbookName.Value, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = False
frmLoanWBMain.Show
gwbTarget.Close
Set gwbTarget = Nothing
gWBPath = ""
gWBName = ""
lblWorkbookSaved.Enabled = True
cmdUpdateAnotherWorkbook.Visible = True
Exit_cmdSaveUpdatedWB_Click:
Exit Sub
Err_cmdSaveUpdatedWB_Click:
MsgBox "The following error occurred inthe [cmdSaveUpdateWB_Click] event handler." & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & "Error descriptioin: " & Err.Description
Resume Exit_cmdSaveUpdatedWB_Click
End Sub
As noted in the title, the SaveAs operation fails. I've determined that the failure is a result of having the workbook to be saved losing the focus. I can step through the code and get the error. Once the error is generated, selecting Debug in the error message box and then pressing F5 to run the code will result in the workbook saving correctly. Placing Debug.Print statements before and after the Activate method of the worbook to be saved indicates that the active wokbook is the workbook containing the code and the form used to update the workbook. Placing a print statement in the Immediate wondow that prints the ActiveWorkbook.Name will result in printing the name of the workbook to be saved - gwbTarget.Name. Pressing F5 then runs the code correctly.
I have been unable to figure out why the workbook to be saved loses the focus. I placed delays, multiple activation statements, local variables to use for the workbookto be saved, and for the name of the workbook to be saved. Any help or ideas as to why this is happening and how to fix it will be greatly appreciated.
I did make some changes. The code is listed below...
Private Sub cmdSaveUpdatedWB_Click()
On Error GoTo Err_cmdSaveUpdatedWB_Click
Dim wbSave As Workbook
Set wbSave = gwbTarget
gwbTarget.Activate
Application.DisplayAlerts = False
''''''' gwbTarget.SaveAs txtUpdWorkbookName.Value, FileFormat:=xlOpenXMLWorkbookMacroEnabled
wbSave.SaveAs fileName:=txtUpdWorkbookName.Value, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = False
frmLoanWBMain.Show
gwbTarget.Close
Set gwbTarget = Nothing
gWBPath = ""
gWBName = ""
lblWorkbookSaved.Enabled = True
cmdUpdateAnotherWorkbook.Visible = True
Exit_cmdSaveUpdatedWB_Click:
Set wbSave = Nothing
Exit Sub
Err_cmdSaveUpdatedWB_Click:
MsgBox "The following error occurred inthe [cmdSaveUpdateWB_Click] event handler." & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & "Error descriptioin: " & Err.Description
Resume Exit_cmdSaveUpdatedWB_Click
End Sub
I've changed the code to more closely resemble the suggestion below. The listing is below, along with the variable definitions as they were upon entry into the program. The Excel code is running in a Citrix environment which may effect timing but shouldn't have any other effect on code execution.
I deleted the other code versions for brevity. The following code is what has worked. The key issue is that the workbook to be saved must be the active workbook when the SaveAs method is invoked.
Private Sub cmdSaveUpdatedWB_Click()
On Error GoTo Err_cmdSaveUpdatedWB_Click
Dim wbSave As Workbook
Dim wsActive As Worksheet
Dim sNWBName As String
Application.DisplayAlerts = False
sNWBName = txtUpdWorkbookName.Value
Set wbSave = gwbTarget
wbSave.Activate
Set wsActive = wbSave.ActiveSheet
wbSave.SaveAs fileName:=sNWBName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True
frmLoanWBMain.Show
gwbTarget.Close
Set gwbTarget = Nothing
gWBPath = ""
gWBName = ""
lblWorkbookSaved.Enabled = True
cmdUpdateAnotherWorkbook.Visible = True
Exit_cmdSaveUpdatedWB_Click:
Set wbSave = Nothing
Exit Sub
Err_cmdSaveUpdatedWB_Click:
Dim strErrMsg As String
strErrMsg = "Error Number: " & Err.Number & " Desc: " & Err.Description & vbCrLf & _
"Source:" & Err.Source & vbCrLf & _
"Updating Workbook: " & vbCrLf & " " & gwbTarget.Name & vbCrLf & _
"Selected Worksheet: " & gwsTrgSheet.Name & vbCrLf & _
"Active Workbook: " & vbCrLf & " " & ActiveWorkbook.Name & vbCrLf & _
"Worksheet: " & ActiveSheet.Name & vbCrLf & _
"Code Segment: cmdSaveUpdatedWB_Click event handler"
RecordErrorInfo strErrMsg
Resume Exit_cmdSaveUpdatedWB_Click
End Sub
Why don't you start with something like this
Private Sub cmdSaveUpdatedWB_Click()
Dim gwbTarget As Workbook
Set gwbTarget = Workbooks("workbook_name.xlsm") 'correct extension needed, workbook must be open
wb.SaveAs Filename:=gwbTarget.Path, FileFormat:=xlOpenXMLWorkbookMacroEnabled
MsgBox "Last saved: " & gwbTarget.BuiltinDocumentProperties("Last Save Time")
End Sub
Change one thing at a time to make it more like yours and hopefully it'll all work fine!
Update
As per the comments. If you are trying to open, update and close hundreds of workbooks. You can use this as a guide:
Sub ChangeWorkbooks()
Application.ScreenUpdating = False
Dim wbPaths As Range, wbSaveFilenames As Range
With Sheet1 'you will need to update this and the ranges below
Set wbPaths = .Range("A1:A650") 'including file extensions
Set wbSaveFilenames = .Range("B1:B650") 'including file extensions
End With
Dim i As Integer, totalBooks As Integer
Dim wbTemp As Workbook
totalBooks = wbPaths.Rows.Count
For i = 1 To totalBooks
Application.StatusBar = "Updating workbook " & i & " of " & totalBooks 'display statusbar message to user
Set wbTemp = Workbooks.Open(wbPaths.Cells(i, 1), False)
'make changes to wbTemp here
wbTemp.SaveAs wbSaveFilenames.Cells(i, 1)
wbTemp.Close
Next i
Set wbTemp = Nothing
Application.ScreenUpdating = True
Applicaton.StatusBar = False
End Sub