I'm trying to print the active worksheet into a PDF file.
I get
"Run-time error '1004'"
It does seem to create the file but can't save it. I know because a printing load window opens for a second.
Dim saveLocation As String
saveLocation = "C:\Users\Desktop\work_hours.pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=saveLocation
Export to PDF
If the reason behind your error is an invalid Desktop path, as user3479671 suspected (in the comments), then the following could be useful.
Run only ExportWorkHours, the rest is being called.
Option Explicit
Sub ExportWorkHours()
' Needs 'SaveAsPDFinDesktop' and 'GetDesktopPath'.
Dim ws As Worksheet: Set ws = ActiveSheet ' be more specific
SaveAsPDFinDesktop ws, "work_hours.pdf"
End Sub
Sub SaveAsPDFinDesktop( _
ByVal ws As Worksheet, _
ByVal pdfFileName As String)
' Needs 'GetDesktopPath'.
Dim DesktopPath As String: DesktopPath = GetDesktopPath
If Len(DesktopPath) = 0 Then
MsgBox "Could not find the Desktop path.", vbCritical
Exit Sub
End If
ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=DesktopPath & pdfFileName
' Explore the file path
'ws.Parent.FollowHyperlink DesktopPath
End Sub
Function GetDesktopPath() As String
Dim DesktopPath As String
DesktopPath = Environ("USERPROFILE") & "\" & "Desktop\"
Dim FolderName As String
FolderName = Dir(DesktopPath, vbDirectory)
If Len(FolderName) = 0 Then
DesktopPath = Environ("OneDrive") & "\" & "Desktop\"
FolderName = Dir(DesktopPath, vbDirectory)
End If
If Len(FolderName) = 0 Then Exit Function
GetDesktopPath = DesktopPath
End Function
Related
I have used the below code to a workbook (SaveAs) and then delete the original file.
The Windows OS put the new created file on the first left vacant space on My Desktop.
What I need after using SaveAs , is to move it’s icon to the same old position of the original file on my Desktop.
Meaning, If my file is initially placed on the upper right of my desktop , I want to keep it in that location after using SaveAs.
In advance, appreciate for your time to help.
Sub Rename_Me_Automatic()
Application.DisplayAlerts = False
Dim FilePath As String, wb As Workbook, FolderPath As String
Dim oldName As String, newName As String
Set wb = ThisWorkbook
FilePath = wb.FullName
FolderPath = wb.Path & Application.PathSeparator
oldName = wb.Name
newName = Left(oldName, Len(oldName) - 5) & WorksheetFunction.RandBetween(1, 20)
wb.SaveAs FolderPath & newName
Kill FilePath 'delete orginal file
Application.DisplayAlerts = True
End Sub
Please, also try this code. It uses classical Windows behavior. VBA writes a VBScript, creates the file and runs it. The script finds the open Excel session, the workbook in discussion, save, close it, quits Excel application in certaing circumstances and changes the workbook name only after that (keeping the same file icon position). Finally, the script kills itself:
Sub SaveAndChangeActiveWorkbookName_VBScript()
Dim vbsStr As String, fso As Object, vbsObj As Object, strVBSPath As String
Dim newName As String, wb As Workbook, ext As String, searchName As String
Set wb = ThisWorkbook
With wb
ext = Split(.Name, ".")(UBound(Split(.Name, ".")))
searchName = Left(.Name, Len(.Name) - (Len(ext) + 1))
End With
newName = searchName & WorksheetFunction.RandBetween(5, 20) & "." & ext
strVBSPath = ThisWorkbook.Path & "\Rename.vbs" 'the fullname of the VBScript to be created and run
vbsStr = "Dim objExcel, wb, objFile, FSO, fullName" & vbCrLf & _
"Set objExcel = GetObject(, ""Excel.Application"")" & vbCrLf & _
"Set FSO = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf & _
" Set wb = objExcel.Workbooks(""" & ThisWorkbook.Name & """)" & vbCrLf & _
"fullName = wb.FullName" & vbCrLf & _
"wb.Close True" & vbCrLf & _
"If objExcel.Workbooks.Count = 0 Then" & vbCrLf & _
" objExcel.Quit" & vbCrLf & _
"ElseIf objExcel.Workbooks.Count = 1 Then" & vbCrLf & _
" If not UCase(Workbooks(1).Name) = ""PERSONAL.XLSB"" Then" & vbCrLf & _
" objExcel.Quit" & vbCrLf & _
" End If" & vbCrLf & _
"End If" & vbCrLf & _
"Set objFile = FSO.GetFile(fullName)" & vbCrLf & _
"objFile.Name = """ & newName & """" & vbCrLf & _
"FSO.DeleteFile Wscript.ScriptFullName, True" 'kill itself...
Set fso = CreateObject("Scripting.FileSystemObject")
Set vbsObj = fso.OpenTextFile(strVBSPath, 2, True)
vbsObj.Write vbsStr 'write the above string in the VBScript file
vbsObj.Close
Shell "cmd.exe /c """ & strVBSPath & """", 0 'execute/run the VBScript
End Sub
The next version tries simplifying your code, not needing any API:
Sub SaveAndChangeActiveWorkbookName_ShellAppl()
Dim sh32 As Object, oFolder As Object, oFolderItem As Object, wb As Workbook
Dim newName As String, ext As String, searchName As String
Set sh32 = CreateObject("Shell.Application")
Set wb = ThisWorkbook
With wb
ext = Split(.Name, ".")(UBound(Split(.Name, "."))) 'extract extension
searchName = Left(.Name, Len(.Name) - (Len(ext) + 1)) 'extract the rest of its name
newName = searchName & WorksheetFunction.RandBetween(5, 20) & _
IIf(showExtension, "." & ext, "") 'it sets correct new name...
.Save
.ChangeFileAccess xlReadOnly '!
Set oFolder = sh32.Namespace(.Path & "\")
Set oFolderItem = oFolder.ParseName(.Name)
oFolderItem.Name = newName
If (UCase(Workbooks(1).Name) = "PERSONAL.XLSB" _
And Workbooks.Count = 2) Or Workbooks.Count = 1 Then
Application.Quit
Else
.Close False 'no need to save it again and it closes faster in this way...
End If
End With
End Sub
'Function to check how 'Hide extension for known file type' is set:
Function showExtension() As Boolean
Dim fileExt As String, Shl As Object, hideExt As Long
fileExt = "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\HideFileExt"
Set Shl = CreateObject("WScript.Shell")
hideExt = Shl.RegRead(fileExt)
If hideExt = 0 Then showExtension = True
End Function
I've been educated that Windows does not allow changing name of an open workbook. Which is true, you cannot do it manually. Windows does not let you do it, this is its philosophy to avoid data loss.
But setting ReadOnly file attribute looks to temporarily remove the file full name from the Windows File Allocation Table. If you try Debug.Print wb.FullFileName before and after changing its attribute, it will show the same (old) one. But it looks that there are ways to do it and letting the open workbook outside the Allocation Table, you can change its name. I did not even imagine this is possible and I consider that this is the most important issue I learned today.
Intro: Windows OS saves the positions of desktop icons somewhere in registry or another location.
When I post my question, I thought the answer will depend on extracting coordinates of (SavedAs workbook icon) on my desktop,
And then using an API method to place it on the old location of the original file.
But , It looks hard for VBA programmers.
So, I tried the idea of #Daniel Dušek :
(The idea was to SaveAs with the original file name which will just overwrite the old file and then rename it instead of deleting).
The idea itself is excellent, But using native VBA methods (Name and FileSystemObject. MoveFile) ,
have a possible behavior to move the file beside renaming and I need to imitate how Windows OS works when it rename a file (like when you use right-click and choose Rename),
and also, I cannot rename the open workbook by using (Name and FSO. MoveFile) even after set ChangeFileAccess to xlReadOnly.
But, with using native OS API , you can do much more than you can imagine.
I have got a sophisticated API to Rename Link by the professional #Siddharth Rout
The advantage of this API is you can rename a workbook while it is still open (sure after Change File Access to xlReadOnly) 😊.
Now, All works correctly as expected, and I can SaveAs a file keep it’s icon on desktop at the same old position of the original file.
Sub SaveAs_and_Rename_Me_Automatically()
Dim wb As Workbook, filePath As String, folderPath As String
Dim oldName As String, newName As String, ext As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set wb = ThisWorkbook
filePath = wb.FullName
folderPath = wb.Path & "\"
oldName = fso.GetBaseName(filePath)
ext = fso.GetExtensionName(filePath)
newName = oldName & WorksheetFunction.RandBetween(5, 20) & "." & ext
Application.DisplayAlerts = False
wb.SaveAs folderPath & oldName 'SaveAs with orginal name (just overwrite)
wb.ChangeFileAccess xlReadOnly 'change file access to Read_Only:
SHRenameFile filePath, folderPath & newName 'to rename the Workbook while it is still open!
Application.DisplayAlerts = True
If Workbooks.Count = 1 Then
Application.Quit
Else
ThisWorkbook.Close SaveChanges:=True
End If
End Sub
And this the great API to rename:
Private Declare PtrSafe Function SHFileOperation Lib "shell32.dll" _
Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As LongPtr
Private Const FOF_SIMPLEPROGRESS = &H100
Private Const FO_RENAME = &H4
Private Type SHFILEOPSTRUCT
hWnd As LongPtr
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAborted As Boolean
hNameMaps As LongPtr
sProgress As String
End Type
Public Sub SHRenameFile(ByVal strSource As String, ByVal strTarget As String)
Dim op As SHFILEOPSTRUCT
With op
.wFunc = FO_RENAME
.pTo = strTarget
.pFrom = strSource
.fFlags = FOF_SIMPLEPROGRESS
End With
SHFileOperation op '~~> Perform operation
End Sub
a bit hacky setup but works, the idea is following:
save workbook with the suffix "to_del"
from that temp file we rename the original file
save the workbook as the renamed file
delete "to_del" file from the original file
the code:
Sub Rename_Me_Automatic()
Application.DisplayAlerts = False
Dim filePath As String
Dim folderPath As String
Dim oldName As String
Dim newName As String
Dim wb As Workbook
Set wb = ThisWorkbook
filePath = wb.FullName
folderPath = wb.path & Application.PathSeparator
oldName = wb.Name
newName = Left(oldName, Len(oldName) - 5) & WorksheetFunction.RandBetween(1, 20)
wb.SaveAs Filename:=folderPath & newName & "_to_del.xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Name folderPath & oldName As folderPath & newName & ".xlsm"
wb.SaveAs Filename:=folderPath & newName & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Kill folderPath & newName & "_to_del.xlsm"
Application.DisplayAlerts = True
End Sub
You do not say anything...
I have something to do in the next time interval, so I prepared a workaround, but working code based on my comment to your answer assumption, respectively:
A workbook named as the one keeping the code, only having a different numeric suffix before its extension, must exist on Desktop, like reference for the place where the other workbook to be placed;
Your code creates a new workbook, with a random (new) suffix.
ThisWorkbook is saved overwriting the existing workbook on Desktop, but using SaveCopyAs, to let the original workbook open and the overwitted workbook to be renamed (not being open):
Private Sub testSaveCopyAsOverwrite()
'References:
'Microsoft Shell Controls And Automation '(C:\Windows\System32\Shell32.dll)
Dim oShell As Shell32.Shell, oFolder As Shell32.Folder, oFolderItem As Shell32.FolderItem
Dim filePath As String, initFileName As String, newFileName As String, wb As Workbook
Dim thisName As String, newName As String, ext As String, searchName As String
filePath = "C:\Users\Fane Branesti\OneDrive\Desktop\"
Set wb = ThisWorkbook
thisName = wb.name
ext = Split(thisName, ".")(UBound(Split(thisName, ".")))
searchName = left(thisName, Len(thisName) - (Len(ext) + 1))
RecreateName: 'for the case when RandBetween returns the same name suffix...
newName = searchName & WorksheetFunction.RandBetween(5, 20) & "." & ext
Set oShell = New Shell32.Shell
initFileName = Dir(filePath & searchName & "*." & ext) 'find the file to be overwriten
If initFileName <> "" Then
If newName = initFileName Then GoTo RecreateName 'if RandBetween returned the same suffix...
ThisWorkbook.SaveCopyAs fileName:=filePath & initFileName 'overwrite the existing workbook, but keeping the original wb open
Set oFolder = oShell.NameSpace(filePath)
Set oFolderItem = oFolder.ParseName(initFileName)
oFolderItem.name = newName 'change the initial file name with the necessary one, without moving it!
Else
MsgBox "No any workbook having the name pattern as: """ & filePath & searchName & """*." & ext & """"
End If
End Sub
Please, take care to add the required reference (from C:\Windows\System32\Shell32.dll) before running it...
In fact, you can run the next code to add it:
Sub addShellControlsAndAutomation()
'Add a reference to 'Microsoft Shell Controls And Automation':
'In case of error ('Programmatic access to Visual Basic Project not trusted'):
'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
' check "Trust access to the VBA project object model"
On Error Resume Next
Application.vbE.ActiveVBProject.References.AddFromFile "C:\Windows\System32\Shell32.dll"
If err.number = 32813 Then
err.Clear: On Error GoTo 0
MsgBox "'Microsoft Shell Controls And Automation' reference already added...", vbInformation, _
"Reference already existing"
End If
On Error GoTo 0
End Sub
I need help to handle runtime error 9.
My goals is to create a new workbook that compile specific sheet (Master User) from all excel workbook in a folder.
I'm stuck while using "on error goto" because i don't get it how to set the program while error (sheet doesn't exist) goto next workbook.
My code now cause me stuck in an never ending loop on a workbook that didn't have "master user" sheet
Sub Master()
Dim MyFiles As String
Dim Path As String
Dim myExtension As String
Dim Filename As String
Workbooks.Add.SaveAs Filename:="Master", FileFormat:=51
Path = "D:\My Document\"
myExtension = "*.xls*"
MyFiles = Dir(Path & myExtension)
On Error GoTo test
DoAgain:
Do While MyFiles <> ""
Workbooks.Open (Path & MyFiles)
Sheets("master user").Select
ActiveSheet.Rows(1).Copy
Workbooks("Master.xlsx").Activate
Sheets.Add After:=Sheets(Sheets.Count)
Range("A1").PasteSpecial xlPasteAll
If InStr(MyFiles, ".") > 0 Then
Filename = Left(MyFiles, InStr(MyFiles, ".") - 1)
End If
ActiveSheet.Name = Filename
Workbooks(Filename).Activate
Application.CutCopyMode = False
ActiveWorkbook.Close SaveChanges:=False
MyFiles = Dir
Loop
Workbooks("Master.xlsx").Activate
ActiveWorkbook.Close SaveChanges:=True
test:
ActiveWorkbook.Close SaveChanges:=False
Resume DoAgain
ActiveWorkbook.Save
End Sub
Copy Worksheet Ranges From Multiple Workbooks to a New Workbook
The Workbooks
The workbook containing this code (ThisWorkbook).
The source workbook i.e. each workbook (file) found in the source folder.
The destination workbook i.e. a newly added workbook that will be copied to.
Description
This will copy the first row of a same-named worksheet of each workbook (file) found in a folder to a newly added (and renamed) worksheet (multiple) of a new workbook (one).
Option Explicit
Sub CreateMaster()
Const ProcName As String = "CreateMaster"
On Error GoTo ClearError
' Source
Const sFolderPath As String = "D:\My Document\" ' maybe a missing 's'?
Const sFilePattern As String = "*"
Const sExtensionPattern As String = ".xls*"
Const swsName As String = "Master User"
' Destination
Const dFileName As String = "Master.xlsx"
' You never mentioned the destination path ('Master.xlsx') so I chose
' the same path as the path of the workbook containing this code.
' Omitting this path will lead to unexpected results (errors).
Dim dFilePath As String: dFilePath = ThisWorkbook.Path & "\"
Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
' Check if the source folder exists.
If Len(Dir(sFolderPath, vbDirectory)) = 0 Then
MsgBox "The folder '" & sFolderPath & "' doesn't exist.", _
vbCritical, ProcName
Exit Sub
End If
' Return the paths of the files of the source folder in a collection.
Dim sFilePaths As Collection
Set sFilePaths = CollFilePaths(sFolderPath, sFilePattern, sExtensionPattern)
If sFilePaths Is Nothing Then ' no files found
MsgBox "No '" & sExtensionPattern & "'- files found in folder '" _
& sFolderPath & "'.", vbCritical, ProcName
Exit Sub
End If
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
Dim sFilePath As Variant
Dim dwb As Workbook
Dim dws As Worksheet
Dim dwbCreated As Boolean
' Loop through the elements (file paths) of the collection.
For Each sFilePath In sFilePaths
Set swb = Workbooks.Open(sFilePath)
' Attempt to create a reference to the source worksheet.
On Error Resume Next
Set sws = swb.Worksheets(swsName)
On Error GoTo ClearError
If Not sws Is Nothing Then ' source worksheet exists
' Add a new worksheet/workbook.
If dwbCreated Then ' destination workbook created
Set dws = dwb.Worksheets _
.Add(After:=dwb.Sheets(dwb.Sheets.Count))
Else ' destination workbook not created
Set dwb = Workbooks.Add(xlWBATWorksheet) ' one worksheet
Set dws = dwb.Worksheets(1)
dwbCreated = True
End If
' Attempt to rename the destination worksheet.
On Error Resume Next
dws.Name = Left(swb.Name, InStrRev(swb.Name, ".") - 1)
On Error GoTo ClearError
' Copy source to destination.
sws.Rows(1).Copy dws.Rows(1)
Set sws = Nothing
'Else ' source worksheet doesn't exist
End If
swb.Close SaveChanges:=False
Next sFilePath
If dwbCreated Then
dwb.Worksheets(1).Activate
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs dFilePath & dFileName, dFileFormat
Application.DisplayAlerts = True
dwb.Close
MsgBox "Master created.", vbInformation, ProcName
Else
MsgBox "Non of the opened workbooks contained a worksheet " _
& "named '" & swsName & "'.", vbExclamation, ProcName
End If
Application.ScreenUpdating = False
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the paths of the files of a folder in a collection.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function CollFilePaths( _
ByVal FolderPath As String, _
Optional ByVal FilePattern As String = "*", _
Optional ByVal ExtensionPattern As String = "*") _
As Collection
Const ProcName As String = "CollFilePaths"
On Error GoTo ClearError
Dim pSep As String: pSep = Application.PathSeparator
Dim foPath As String: foPath = FolderPath
If Right(foPath, 1) <> pSep Then foPath = foPath & pSep
Dim ePattern As String: ePattern = ExtensionPattern
If Left(ePattern, 1) <> "." Then ePattern = "." & ePattern
Dim fiName As String: fiName = Dir(foPath & FilePattern & ePattern)
If Len(fiName) = 0 Then Exit Function
Dim coll As Collection: Set coll = New Collection
Do Until Len(fiName) = 0
coll.Add foPath & fiName
fiName = Dir
Loop
Set CollFilePaths = coll
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
I am a newbie in excel vba coding and trying to create pdf of a excel sheet range. My code works well in windows OS but somehow it doesn't work in Mac OS. The Code is as below:
`
Sub GeneratePDF()
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
Dim VelleName As String
Dim SelectedRange As Range
With ThisWorkbook.Worksheets("modulo")
.Activate
.Range(.Cells(1, 1), .Cells(33, 10)).Select
Selection.Name = "SelectedRange"
End With
On Error GoTo errHandler
Set wbA = ActiveWorkbook
Set wsA = ActiveWorkbook.Worksheets("modulo")
strTime = Format(Now(), "ddmmyyyy\_hhmm")
'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
VelleName = ThisWorkbook.Worksheets("database").Range("B" & Desiredrow) & "_" & ThisWorkbook.Worksheets("database").Range("C" & Desiredrow)
'replace spaces and periods in sheet name
strName = Replace(VelleName, " ", "_")
strName = Replace(strName, ".", "_")
strName = Replace(strName, "-", "_")
strName = Replace(strName, "/", "_")
'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strName & "_" & strTime
' select folder for file
If Dir(strPath & Application.PathSeparator & "forme", vbDirectory) = "" Then '<== check if folder exists but its not detecting even though i had created a folder there.
MkDir (ThisWorkbook.Path & Application.PathSeparator & "forme") '<== Create Folder and its not working for Mac OS.
End If
myFile = ThisWorkbook.Path & Application.PathSeparator & "forme" & Application.PathSeparator & strPathFile
'export to PDF if a folder was selected
If myFile <> "False" Then
With wsA.PageSetup
.Orientation = xlPortrait
.PrintArea = "SelectedRange"
.Zoom = False
.FitToPagesTall = 1
.FitToPagesWide = 1
End With
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
MsgBox "Il file pdf è stato creato: " _
& vbCrLf _
& myFile
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Impossibile creare il file pdf"
Resume exitHandler
End Sub
`
I have tried searching a lot on internet but havent found any source which specifically teaches vba coding in Mac OS. Moreover, i got only one link https://macexcel.com/examples/filesandfolders/makefolder/ but i dont think it would work as it should be only one line of command and the biggest issue i dont have Mac OS available now. So can somebody test my code change my command to make it compatible it with Mac OS
I used to use this code and also add to check file exist
'Only Change code Here
Sub Verify()
Dim myPath As String
myPath = "C:\abc" '<--------This line
If Not PathExist(myPath) Then MkDir (myPath)
End Sub
Private Function PathExist(path_ As String) As Boolean
On Error GoTo ErrNotExist
Call ChDir(path_)
PathExist = True
Exit Function
ErrNotExist:
PathExist = False
End Function
Private Function FileExist(filePath_ As String) As Boolean
FileExist = Len(Dir(filePath_)) <> 0
End Function
I want to save Excel files in both the local drive and in the network folder. Currently I am doing it with SaveAs (local) and another SaveAs (network), is it faster to do a SaveAs then FileCopy?
Code below:
Sub SaveAs()
Dim ws As Worksheet
Dim ws_console As Worksheet
Dim long_col_number As Long
Dim long_sheets_count As Long
Dim arr_sheet_names As Variant
Dim str_password As String
Dim str_datetoday As String
Dim str_datetoday_path As String
Dim str_datetoday_network_path As String
str_datetoday = Format(Date, "yyyy-mm-dd")
str_datetoday_path = "C:\Users\" & Environ("Username") & "\Desktop\Report\" & str_datetoday
str_datetoday_network_path = "\\servername\data\reports\US Reports Daily\" & str_datetoday
If Dir(str_datetoday_path, vbDirectory) = "" Then
MkDir (str_datetoday_path)
MsgBox "Making directory"
End If
If Dir(str_datetoday_network_path, vbDirectory) = "" Then
MkDir (str_datetoday_network_path)
End If
For Each ws In ThisWorkbook.Worksheets
If ws.CodeName = "AILD_01_Console" Then
Set ws_console = ws
Exit For
End If
Next ws
long_col_number = 0
For long_col_number = 1 To 8
long_sheets_count = Application.WorksheetFunction.CountA(ws_console.Range(Cells(16, long_col_number), Cells(24, long_col_number)))
arr_sheet_names = ws_console.Range(Cells(16, long_col_number), Cells(15 + long_sheets_count, long_col_number))
arr_sheet_names = Application.WorksheetFunction.Transpose(arr_sheet_names)
Worksheets(arr_sheet_names).Copy
ActiveWorkbook.SaveAs _
Filename:=str_datetoday_path & "\" & ws_console.Cells(15, long_col_number) & " - " & Format(Date, "yyyy-mm-dd"), _
FileFormat:=51
ActiveWorkbook.SaveAs _
Filename:=str_datetoday_network_path & "\" & ws_console.Cells(15, long_col_number), _
FileFormat:=51
ActiveWorkbook.Close False
Next long_col_number
ws_console.Activate
End Sub
Thank you very much for all the help.
How do I save each sheet in an Excel workbook to separate CSV files with a macro?
I have an excel with multiple sheets and I was looking for a macro that will save each sheet to a separate CSV (comma separated file). Excel will not allow you to save all sheets to different CSV files.
#AlexDuggleby: you don't need to copy the worksheets, you can save them directly. e.g.:
Public Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
SaveToDirectory = "C:\"
For Each WS In ThisWorkbook.Worksheets
WS.SaveAs SaveToDirectory & WS.Name, xlCSV
Next
End Sub
Only potential problem is that that leaves your workbook saved as the last csv file. If you need to keep the original workbook you will need to SaveAs it.
Here is one that will give you a visual file chooser to pick the folder you want to save the files to and also lets you choose the CSV delimiter (I use pipes '|' because my fields contain commas and I don't want to deal with quotes):
' ---------------------- Directory Choosing Helper Functions -----------------------
' Excel and VBA do not provide any convenient directory chooser or file chooser
' dialogs, but these functions will provide a reference to a system DLL
' with the necessary capabilities
Private Type BROWSEINFO ' used by the function GetFolderName
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim X As Long, pos As Integer
bInfo.pidlRoot = 0& ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
' the dialog title
Else
bInfo.lpszTitle = Msg ' the dialog title
End If
bInfo.ulFlags = &H1 ' Type of directory to return
X = SHBrowseForFolder(bInfo) ' display the dialog
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal X, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetFolderName = Left(path, pos - 1)
Else
GetFolderName = ""
End If
End Function
'---------------------- END Directory Chooser Helper Functions ----------------------
Public Sub DoTheExport()
Dim FName As Variant
Dim Sep As String
Dim wsSheet As Worksheet
Dim nFileNum As Integer
Dim csvPath As String
Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", _
"Export To Text File")
'csvPath = InputBox("Enter the full path to export CSV files to: ")
csvPath = GetFolderName("Choose the folder to export CSV files to:")
If csvPath = "" Then
MsgBox ("You didn't choose an export directory. Nothing will be exported.")
Exit Sub
End If
For Each wsSheet In Worksheets
wsSheet.Activate
nFileNum = FreeFile
Open csvPath & "\" & _
wsSheet.Name & ".csv" For Output As #nFileNum
ExportToTextFile CStr(nFileNum), Sep, False
Close nFileNum
Next wsSheet
End Sub
Public Sub ExportToTextFile(nFileNum As Integer, _
Sep As String, SelectionOnly As Boolean)
Dim WholeLine As String
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String
Application.ScreenUpdating = False
On Error GoTo EndMacro:
If SelectionOnly = True Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Else
With ActiveSheet.UsedRange
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #nFileNum, WholeLine
Next RowNdx
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
And here's my solution should work with Excel > 2000, but tested only on 2007:
Private Sub SaveAllSheetsAsCSV()
On Error GoTo Heaven
' each sheet reference
Dim Sheet As Worksheet
' path to output to
Dim OutputPath As String
' name of each csv
Dim OutputFile As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
' ask the user where to save
OutputPath = InputBox("Enter a directory to save to", "Save to directory", Path)
If OutputPath <> "" Then
' save for each sheet
For Each Sheet In Sheets
OutputFile = OutputPath & "\" & Sheet.Name & ".csv"
' make a copy to create a new book with this sheet
' otherwise you will always only get the first sheet
Sheet.Copy
' this copy will now become active
ActiveWorkbook.SaveAs FileName:=OutputFile, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next
End If
Finally:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Sub
Heaven:
MsgBox "Couldn't save all sheets to CSV." & vbCrLf & _
"Source: " & Err.Source & " " & vbCrLf & _
"Number: " & Err.Number & " " & vbCrLf & _
"Description: " & Err.Description & " " & vbCrLf
GoTo Finally
End Sub
(OT: I wonder if SO will replace some of my minor blogging)
Building on Graham's answer, the extra code saves the workbook back into it's original location in it's original format.
Public Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
' Store current details for the workbook
SaveToDirectory = "C:\"
For Each WS In ThisWorkbook.Worksheets
WS.SaveAs SaveToDirectory & WS.Name, xlCSV
Next
Application.DisplayAlerts = False
ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat
Application.DisplayAlerts = True
' Temporarily turn alerts off to prevent the user being prompted
' about overwriting the original file.
End Sub
A small modification to answer from Alex is turning on and off of auto calculation.
Surprisingly the unmodified code was working fine with VLOOKUP but failed with OFFSET. Also turning auto calculation off speeds up the save drastically.
Public Sub SaveAllSheetsAsCSV()
On Error GoTo Heaven
' each sheet reference
Dim Sheet As Worksheet
' path to output to
Dim OutputPath As String
' name of each csv
Dim OutputFile As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
' Save the file in current director
OutputPath = ThisWorkbook.Path
If OutputPath <> "" Then
Application.Calculation = xlCalculationManual
' save for each sheet
For Each Sheet In Sheets
OutputFile = OutputPath & Application.PathSeparator & Sheet.Name & ".csv"
' make a copy to create a new book with this sheet
' otherwise you will always only get the first sheet
Sheet.Copy
' this copy will now become active
ActiveWorkbook.SaveAs Filename:=OutputFile, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next
Application.Calculation = xlCalculationAutomatic
End If
Finally:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Sub
Heaven:
MsgBox "Couldn't save all sheets to CSV." & vbCrLf & _
"Source: " & Err.Source & " " & vbCrLf & _
"Number: " & Err.Number & " " & vbCrLf & _
"Description: " & Err.Description & " " & vbCrLf
GoTo Finally
End Sub
For Mac users like me, there are several gotchas:
You cannot save to any directory you want. Only few of them can receive your saved files. More info there
Here is a working script that you can copy paste in your excel for Mac:
Public Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
SaveToDirectory = "~/Library/Containers/com.microsoft.Excel/Data/"
For Each WS In ThisWorkbook.Worksheet
WS.SaveAs SaveToDirectory & WS.Name & ".csv", xlCSV
Next
End Sub
Use Visual Basic to loop through worksheets and save .csv files.
Open up .xlsx file in Excel.
Press option+F11
Insert → Module
Insert this into the module code:
Public Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
SaveToDirectory = "./"
For Each WS In ThisWorkbook.Worksheets
WS.SaveAs SaveToDirectory & WS.Name & ".csv", xlCSV
Next
End Sub
Run the module.
(i.e. Click the play button at the top and then click "Run" on the dialog, if it pops up.)
Find your .csv files in ~/Library/Containers/com.microsoft.Excel/Data.
open ~/Library/Containers/com.microsoft.Excel/Data
Close .xlsx file.
Rinse and repeat for other .xlsx files.
Please look into Von Pookie's answer, all credits to him/her.
Sub asdf()
Dim ws As Worksheet, newWb As Workbook
Application.ScreenUpdating = False
For Each ws In Sheets(Array("EID Upload", "Wages with Locals Upload", "Wages without Local Upload"))
ws.Copy
Set newWb = ActiveWorkbook
With newWb
.SaveAs ws.Name, xlCSV
.Close (False)
End With
Next ws
Application.ScreenUpdating = True
End Sub