I want to create a macro for exporting all Excel charts from several workbooks in one folder.
I'm a beginner in VBA and I need your help with the following code:
P.S. The code seems to work (I don't have errors) but does not export any graph to the selected folder.
Could you, please, help me with some hints? I don`t know where is the problem.
Thank you in advance! :)
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them (export all charts in one folder)
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim objChart As Excel.Chart
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
'myExtension = "*.xls*"
myExtension = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
For Each objChart In wb.Charts
objChart.Export myPath & Left(wb.Name, Len(wb.Name) - 5) & "_" & objChart.Name & ".png"
Next objChart
For Each objSheet In wb.Worksheets
For Each objChartObject In objSheet.ChartObjects
With objChartObject.Chart
.Export myPath & Left(wb.Name, Len(wb.Name) - 4) & "_" & .Name & "png" '/export graphs with WorkbookName + _worksheet name
End With
Next
Next
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'Open the windows folder
Shell "Explorer.exe" & " " & myPath, vbNormalFocus
End Sub
Maybe is useful to mention that I wanted to adapt one of my oldest macro (this one export all the charts from a workbook in one folder. Now I need to export all the charts from multiple workbooks in one folder).
Sub ExportAllCharts()
'
' '
' This macro extracts all the graphs from an Excel document and imports them into the selected folder as .PNG images. '
'
' '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim objShell As Object
Dim objWindowsFolder As Object
Dim strWindowsFolder As String
Dim objSheet As Excel.Worksheet
Dim objChartObject As Excel.ChartObject
Dim objChart As Excel.Chart
'Sheets.Select
'ActiveSheet.Select
'Select a Windows folder
Set objShell = CreateObject("Shell.Application")
Set objWindowsFolder = objShell.BrowseForFolder(0, "Select a Windows folder:", 0, "")
If Not objWindowsFolder Is Nothing Then
strWindowsFolder = objWindowsFolder.self.Path & "\"
''''''''''''''''''''''''''
' charts on chart sheets '
''''''''''''''''''''''''''
'For Each objChart In ThisWorkbook.Charts
For Each objChart In ActiveWorkbook.Charts
objChart.Export strWindowsFolder & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) & "_" & objChart.Name & ".png" '/export graphs with workbook name prefix + _ + worksheet name ( ex: WorkbookName_WorksheetName.png ---> OK)
Next objChart
'Open the windows folder
Shell "Explorer.exe" & " " & strWindowsFolder, vbNormalFocus
End If
End Sub
I have the following code I wrote in Excel:
Sub Multiple()
MyDir = ActiveWorkbook.Path
strPath = MyDir & ":"
strFile = Dir(strPath, MacID("TEXT"))
'Loop through each file in the folder
Do While Len(strFile) > 0
If Right(strFile, 3) = "csv" Then
Debug.Print strFile
DoWork (strFile)
End If
strFile = Dir
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
Range("E:E,K:K").Select
Range("K1").Activate
Selection.Delete Shift:=xlToLeft
ActiveSheet.Range("b1").End(xlDown).Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-3]C:R[-1]C)/1000"
ActiveSheet.Range("b1").End(xlDown).Select
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.Offset(0, 2)), Type:=xlFillDefault
ActiveSheet.Range("e1").End(xlDown).Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-3]C:R[-1]C)"
ActiveSheet.Range("e1").End(xlDown).Select
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.Offset(0, 4)), Type:=xlFillDefault
End With
End Sub
What I am trying to do is run the bottom Sub DoWork() which does some basic editing on an excel file on my macintosh on multiple files.
For that I wrote the uper Sub Multiple() which should eventually run the bottom Sub on multiple files.
The files type are CSV files.
The bottom code works perfect when running it individually on each Excel file.
However, the top code does not do the trick of running on all multiple files.
Anyone have an idea why?
In your Multiple code, you are passing a string parameter (the filename) to DoWork, but DoWork is expecting you to pass a Workbook object.
You will need to join strPath and strFile together (in Windows that would be strPath & "\" & strFile - I assume it will be something similar on a Mac) and then open the Workbook. I would suggest the following code should be used where you currently are just doing DoWork (strFile):
Set wb = Workbooks.Open(strPath & "\" & strFile) ' Adjust to suit for Mac filename syntax
DoWork wb
wb.Save
wb.Close False
Ok. Figured it out :-)
Sub Multiple()
Dim SecDir As String
Dim MyDir As String
Dim wbk As Workbook
MyDir = "tlv-mpzyw:Users:lcohen:Google Drive:SQA:Projects:vbaBotRegression:"
SecDir = "files:"
strPath = MyDir & SecDir
Debug.Print strPath
strFile = Dir(strPath)
'Loop through each file in the folder
Do While Len(strPath) > 0
If Right(strFile, 3) = "csv" Then
Debug.Print strFile
Set wbk = Workbooks.Open(Filename:=strPath & strFile)
Range("E:E,K:K").Select
Range("K1").Activate
Selection.Delete Shift:=xlToLeft
ActiveSheet.Range("b1").End(xlDown).Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-3]C:R[-1]C)/1000"
ActiveSheet.Range("b1").End(xlDown).Select
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.Offset(0, 2)), Type:=xlFillDefault
ActiveSheet.Range("e1").End(xlDown).Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-3]C:R[-1]C)"
ActiveSheet.Range("e1").End(xlDown).Select
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.Offset(0, 4)), Type:=xlFillDefault
wbk.Close SaveChanges:=False
End If
strFile = Dir
Loop
End Sub
Now I have another issue,
Am getting the following error message:
Run-time error '1004':
'TLV-MPZYW:USERS:LCOHEN:GOOGLE
DRIVE:SQA:PROJECTS:VBABOTREGRESSION:FILES:SAMPLES_MULTIPLE_FILTERS_QUERIES-STATISTICS.CSV'
could not be found.Check the spelling of the file name, and verify
that the file location is correct.
If you are trying to open the file from your list of most recently
used files on the File menu, make sure that the file has not been
renamed, moved, or deleted.
I am clueless at this point on what might be causing this issue.
As you can see in my code, I am printing the file name to verify that it indeed reads it correctly.
Anyone?????
I am trying to open a user form which I have created in a PPTM file via VBScript. Code for VB script is as below. This does seem to be working. It is simply opening that macro PPTM and closing it. Any suggestions?
Option Explicit
Dim pptApp, pptPresentation, CurrentDirectory
dim fso: set fso = CreateObject("Scripting.FileSystemObject")
CurrentDirectory = fso.GetAbsolutePathName(".")
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPresentation = pptApp.Presentations.Open(CurrentDirectory + "\Revison Macro V1.pptm",True)
On Error Resume Next
pptApp.Run "Revision"
If Err Then
End If
pptPresentation.Close
pptApp.Quit
Set pptPresentation = Nothing
Set pptApp = Nothing
WScript.Quit
A Few code revisions
Set pptPresentation = pptApp.Presentations.Open(CurrentDirectory + "\Revison Macro V1.pptm",True) >> VBScript uses "&" rather than "+" even though this worked fine, it's better to stick to the correct string handling.
The userform needs to be indirectly called to pause the vbscript. So create a separate Sub and call it "Call_Revision". The code will be simple and straightforward as follows:
Sub Call_Revision
Revision.Show
End Sub
When you execute the .Run command, it needs to know how to find the code to run the UserForm. So now that we have established our sub, we can use that to show the form.
From: pptApp.Run "Revision"
To: pptApp.Run "Revison Macro V1.pptm!Module1.Call_Revision"
If you are waiting for the user to close out the userform to execute the rest of the code and exit the PPTM file, you can apply the following OnClose event within the Userform:
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Application.Quit
End Sub
And the Full Code:
Option Explicit
Dim currppt : currppt = "Revison Macro V1.pptm"
Dim ModuleName: ModuleName = "Module1"
Dim OpenUF : OpenUF = "Call_Revision"
Dim pptApp, pptPresentation, CurrentDirectory
dim fso: set fso = CreateObject("Scripting.FileSystemObject")
CurrentDirectory = fso.GetAbsolutePathName(".")
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPresentation = pptApp.Presentations.Open(CurrentDirectory & "\" & currppt,True)
On Error Resume Next
pptApp.Run currppt & "!" & ModuleName & "." & OpenUF
msgbox "Done"
pptPresentation.Close
pptApp.Quit
Set pptPresentation = Nothing
Set pptApp = Nothing
How could I convert an XLS file to a CSV file on the windows command line.
The machine has Microsoft Office 2000 installed. I'm open to installing OpenOffice if it's not possible using Microsoft Office.
Open Notepad, create a file called XlsToCsv.vbs and paste this in:
if WScript.Arguments.Count < 2 Then
WScript.Echo "Error! Please specify the source path and the destination. Usage: XlsToCsv SourcePath.xls Destination.csv"
Wscript.Quit
End If
Dim oExcel
Set oExcel = CreateObject("Excel.Application")
Dim oBook
Set oBook = oExcel.Workbooks.Open(Wscript.Arguments.Item(0))
oBook.SaveAs WScript.Arguments.Item(1), 6
oBook.Close False
oExcel.Quit
WScript.Echo "Done"
Then from a command line, go to the folder you saved the .vbs file in and run:
XlsToCsv.vbs [sourcexlsFile].xls [destinationcsvfile].csv
This requires Excel to be installed on the machine you are on though.
A slightly modified version of ScottF answer, which does not require absolute file paths:
if WScript.Arguments.Count < 2 Then
WScript.Echo "Please specify the source and the destination files. Usage: ExcelToCsv <xls/xlsx source file> <csv destination file>"
Wscript.Quit
End If
csv_format = 6
Set objFSO = CreateObject("Scripting.FileSystemObject")
src_file = objFSO.GetAbsolutePathName(Wscript.Arguments.Item(0))
dest_file = objFSO.GetAbsolutePathName(WScript.Arguments.Item(1))
Dim oExcel
Set oExcel = CreateObject("Excel.Application")
Dim oBook
Set oBook = oExcel.Workbooks.Open(src_file)
oBook.SaveAs dest_file, csv_format
oBook.Close False
oExcel.Quit
I have renamed the script ExcelToCsv, since this script is not limited to xls at all. xlsx Works just fine, as we could expect.
Tested with Office 2010.
A small expansion on ScottF's groovy VB script: this batch file will loop through the .xlsx files in a directory and dump them into *.csv files:
FOR /f "delims=" %%i IN ('DIR *.xlsx /b') DO ExcelToCSV.vbs "%%i" "%%i.csv"
Note: You may change extension .xlsx to .xls andname of script ExcelToCSV to XlsToCsv
How about with PowerShell?
Code should be looks like this, not tested though
$xlCSV = 6
$Excel = New-Object -Com Excel.Application
$Excel.visible = $False
$Excel.displayalerts=$False
$WorkBook = $Excel.Workbooks.Open("YOUDOC.XLS")
$Workbook.SaveAs("YOURDOC.csv",$xlCSV)
$Excel.quit()
Here is a post explaining how to use it
How Can I Use Windows PowerShell to Automate Microsoft Excel?
I had a need to extract several cvs from different worksheets, so here is a modified version of plang code that allows you to specify the worksheet name.
if WScript.Arguments.Count < 3 Then
WScript.Echo "Please specify the sheet, the source, the destination files. Usage: ExcelToCsv <sheetName> <xls/xlsx source file> <csv destination file>"
Wscript.Quit
End If
csv_format = 6
Set objFSO = CreateObject("Scripting.FileSystemObject")
src_file = objFSO.GetAbsolutePathName(Wscript.Arguments.Item(1))
dest_file = objFSO.GetAbsolutePathName(WScript.Arguments.Item(2))
Dim oExcel
Set oExcel = CreateObject("Excel.Application")
Dim oBook
Set oBook = oExcel.Workbooks.Open(src_file)
oBook.Sheets(WScript.Arguments.Item(0)).Select
oBook.SaveAs dest_file, csv_format
oBook.Close False
oExcel.Quit
Here is a version that will handle multiple files drag and dropped from windows.
Based on the above works by
Christian Lemer
plang
ScottF
Open Notepad, create a file called XlsToCsv.vbs and paste this in:
'* Usage: Drop .xl* files on me to export each sheet as CSV
'* Global Settings and Variables
Dim gSkip
Set args = Wscript.Arguments
For Each sFilename In args
iErr = ExportExcelFileToCSV(sFilename)
' 0 for normal success
' 404 for file not found
' 10 for file skipped (or user abort if script returns 10)
Next
WScript.Quit(0)
Function ExportExcelFileToCSV(sFilename)
'* Settings
Dim oExcel, oFSO, oExcelFile
Set oExcel = CreateObject("Excel.Application")
Set oFSO = CreateObject("Scripting.FileSystemObject")
iCSV_Format = 6
'* Set Up
sExtension = oFSO.GetExtensionName(sFilename)
if sExtension = "" then
ExportExcelFileToCSV = 404
Exit Function
end if
sTest = Mid(sExtension,1,2) '* first 2 letters of the extension, vb's missing a Like operator
if not (sTest = "xl") then
if (PromptForSkip(sFilename,oExcel)) then
ExportExcelFileToCSV = 10
Exit Function
end if
End If
sAbsoluteSource = oFSO.GetAbsolutePathName(sFilename)
sAbsoluteDestination = Replace(sAbsoluteSource,sExtension,"{sheet}.csv")
'* Do Work
Set oExcelFile = oExcel.Workbooks.Open(sAbsoluteSource)
For Each oSheet in oExcelFile.Sheets
sThisDestination = Replace(sAbsoluteDestination,"{sheet}",oSheet.Name)
oExcelFile.Sheets(oSheet.Name).Select
oExcelFile.SaveAs sThisDestination, iCSV_Format
Next
'* Take Down
oExcelFile.Close False
oExcel.Quit
ExportExcelFileToCSV = 0
Exit Function
End Function
Function PromptForSkip(sFilename,oExcel)
if not (VarType(gSkip) = vbEmpty) then
PromptForSkip = gSkip
Exit Function
end if
Dim oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
sPrompt = vbCRLF & _
"A filename was received that doesn't appear to be an Excel Document." & vbCRLF & _
"Do you want to skip this and all other unrecognized files? (Will only prompt this once)" & vbCRLF & _
"" & vbCRLF & _
"Yes - Will skip all further files that don't have a .xl* extension" & vbCRLF & _
"No - Will pass the file to excel regardless of extension" & vbCRLF & _
"Cancel - Abort any further conversions and exit this script" & vbCRLF & _
"" & vbCRLF & _
"The unrecognized file was:" & vbCRLF & _
sFilename & vbCRLF & _
"" & vbCRLF & _
"The path returned by the system was:" & vbCRLF & _
oFSO.GetAbsolutePathName(sFilename) & vbCRLF
sTitle = "Unrecognized File Type Encountered"
sResponse = MsgBox (sPrompt,vbYesNoCancel,sTitle)
Select Case sResponse
Case vbYes
gSkip = True
Case vbNo
gSkip = False
Case vbCancel
oExcel.Quit
WScript.Quit(10) '* 10 Is the error code I use to indicate there was a user abort (1 because wasn't successful, + 0 because the user chose to exit)
End Select
PromptForSkip = gSkip
Exit Function
End Function
You can do it with Alacon - command-line utility for Alasql database. It works with Node.js, so you need to install Node.js and then Alasql package.
To convert Excel file to CVS (ot TSV) you can enter:
> node alacon "SELECT * INTO CSV('mydata.csv', {headers:true}) FROM XLS('mydata.xls', {headers:true})"
By default Alasql converts data from "Sheet1", but you can change it with parameters:
{headers:false, sheetid: 'Sheet2', range: 'A1:C100'}
Alacon supports other type of conversions (CSV, TSV, TXT, XLSX, XLS) and SQL language constructions (see User Manual for examples).
Why not write your own?
I see from your profile you have at least some C#/.NET experience. I'd create a Windows console application and use a free Excel reader to read in your Excel file(s). I've used Excel Data Reader available from CodePlex without any problem (one nice thing: this reader doesn't require Excel to be installed). You can call your console application from the command line.
If you find yourself stuck post here and I'm sure you'll get help.
:: For UTF-8 works for Microsoft Office 2016 and higher!
Try this code:
if WScript.Arguments.Count < 2 Then
WScript.Echo "Please specify the source and the destination files. Usage: ExcelToCsv <xls/xlsx source file> <csv destination file>"
Wscript.Quit
End If
csv_format = 62
Set objFSO = CreateObject("Scripting.FileSystemObject")
src_file = objFSO.GetAbsolutePathName(Wscript.Arguments.Item(0))
dest_file = objFSO.GetAbsolutePathName(WScript.Arguments.Item(1))
Dim oExcel
Set oExcel = CreateObject("Excel.Application")
Dim oBook
Set oBook = oExcel.Workbooks.Open(src_file)
oBook.SaveAs dest_file, csv_format
oBook.Close False
oExcel.Quit
There's an Excel OLEDB data provider built into Windows; you can use this to 'query' the Excel sheet via ADO.NET and write the results to a CSV file. There's a small amount of coding required, but you shouldn't need to install anything on the machine.
Building on what Jon of All Trades has provided, the following (~n) removed the pesky double extension issue:
FOR /f "delims=" %%i IN ('DIR *.xlsx /b') DO ExcelToCSV.vbs "%%i" "%%~ni.csv"
Create a TXT file on your desktop named "xls2csv.vbs" and paste the code:
Dim vExcel
Dim vCSV
Set vExcel = CreateObject("Excel.Application")
Set vCSV = vExcel.Workbooks.Open(Wscript.Arguments.Item(0))
vCSV.SaveAs WScript.Arguments.Item(0) & ".csv", 6
vCSV.Close False
vExcel.Quit
Drag a XLS file to it (like "test.xls"). It will create a converted CSV file named "test.xls.csv". Then, rename it to "test.csv". Done.
I tried ScottF VB solution and got it to work. However I wanted to convert a multi-tab(workbook) excel file into a single .csv file.
This did not work, only one tab(the one that is highlighted when I open it via excel) got copied.
Is any one aware of a script that can convert a multi-tab excel file into a single .csv file?
Scott F's answer is the best I have found on the internet. I did add on to his code to meet my needs. I added:
On Error Resume Next <- To account for a missing xls files in my batch processing at the top.
oBook.Application.Columns("A:J").NumberFormat = "#" <- Before the SaveAs line to make sure my data is saved formatted as text to keep excel from deleting leading zero's and eliminating commas in number strings in my data i.e. (1,200 to 1200). The column range should be adjusted to meet your neeeds (A:J).
I also removed the Echo "done" to make it non interactive.
I then added the script into a cmd batch file for processing automated data on an hourly basis via a task.
All of these answers helped me construct the following script which will automatically convert XLS* files to CSV and vice versa, by dropping one or more files on the script (or via command line). Apologies for the janky formatting.
' https://stackoverflow.com/questions/1858195/convert-xls-to-csv-on-command-line
' https://gist.github.com/tonyerskine/77250575b166bec997f33a679a0dfbe4
' https://stackoverflow.com/a/36804963/1037948
'* Global Settings and Variables
Set args = Wscript.Arguments
For Each sFilename In args
iErr = ConvertExcelFormat(sFilename)
' 0 for normal success
' 404 for file not found
' 10 for file skipped (or user abort if script returns 10)
Next
WScript.Quit(0)
Function ConvertExcelFormat(srcFile)
if IsEmpty(srcFile) OR srcFile = "" Then
WScript.Echo "Error! Please specify at least one source path. Usage: " & WScript.ScriptName & " SourcePath.xls*|csv"
ConvertExcelFormat = -1
Exit Function
'Wscript.Quit
End If
Set objFSO = CreateObject("Scripting.FileSystemObject")
srcExt = objFSO.GetExtensionName(srcFile)
' the 6 is the constant for 'CSV' format, 51 is for 'xlsx'
' https://msdn.microsoft.com/en-us/vba/excel-vba/articles/xlfileformat-enumeration-excel
' https://www.rondebruin.nl/mac/mac020.htm
Dim outputFormat, srcDest
If LCase(Mid(srcExt, 1, 2)) = "xl" Then
outputFormat = 6
srcDest = "csv"
Else
outputFormat = 51
srcDest = "xlsx"
End If
'srcFile = objFSO.GetAbsolutePathName(Wscript.Arguments.Item(0))
srcFile = objFSO.GetAbsolutePathName(srcFile)
destFile = Replace(srcFile, srcExt, srcDest)
Dim oExcel
Set oExcel = CreateObject("Excel.Application")
Dim oBook
Set oBook = oExcel.Workbooks.Open(srcFile)
' preserve formatting? https://stackoverflow.com/a/8658845/1037948
'oBook.Application.Columns("A:J").NumberFormat = "#"
oBook.SaveAs destFile, outputFormat
oBook.Close False
oExcel.Quit
WScript.Echo "Conversion complete of '" & srcFile & "' to '" & objFSO.GetFileName(destFile) & "'"
End Function
For anyone wondering how to get your LOCAL delimiter to show up in the csv files instead of the comma/tab this is how you do it. This was soo challenging to find and I am amazed no one ran into it before 2022?
if WScript.Arguments.Count < 2 Then
WScript.Echo "Please specify the source and the destination files. Usage: ExcelToCsv <xls/xlsx source file> <csv destination file>"
Wscript.Quit
End If
Set objFSO = CreateObject("Scripting.FileSystemObject")
src_file = objFSO.GetAbsolutePathName(Wscript.Arguments.Item(0))
dest_file = objFSO.GetAbsolutePathName(WScript.Arguments.Item(1))
Dim oExcel
Set oExcel = CreateObject("Excel.Application")
Dim oBook
Set oBook = oExcel.Workbooks.Open(src_file)
local = true
csv_format = 6
oBook.SaveAs dest_file, csv_format, 0, 0, 0, 0, 0, 0, 0, 0, 0, local
oBook.Close False
oExcel.Quit