I am trying to run a PowerPoint Macro through Excel VBA, I used to be able to run a macro on a powerpoint file with ease but I am having trouble passing a parameter in excel.
Sub Test()
Dim arr(1 To 1), macname As String, objPP As Object, PPTFilePath As String, ObjPPFile As Object,
PPtFileName As String
PPTFileName ="Report.pptm"
PPTFilePath ThisWorkbook.Path & PPTFileName
Set objPP = CreateObject("PowerPoint.Application")
objPP.Visible = True
Set objPPFile = objPP.Presentations.Open(PPTFilePath)
Application.EnableEvents = False
arr(1) = ThisWorkbook.Path
macname = "'" & PPTFileName & "'!Module3.UpdateSpecificLinks"
objPP.Run macname, arr
objPPFile.Save
waiting (3)
Application.EnableEvents = True
End Sub
I get an error on objPP.Run macname, arr , it is: Run-time error '-2147188160 (80048240)': Application.Run :Invalid request. Sub or Function not defined.
How do I properly Pass a parameter to the powerpoint macro: Sub UpdateSpecificLinks(LNK as String)
If your SubUpdateSpecificLinks is e.g. in a private module, the call to it will fail; it must be public.
I think this is the problem, though:
macname = "'" & PPTFileName & "'!Module3.UpdateSpecificLinks"
Try this instead:
macname = PPTFileName & "!Module3.UpdateSpecificLinks"
A couple of examples, calling from a PPTM file to another (closed) PPTM file:
Here are the calling macros:
Sub TestWithString()
Dim sFileName As String
Dim oPres As Presentation
sFileName = "C:\temp\runme.pptm"
Set oPres = Presentations.Open(sFileName, , , False)
Application.Run "C:\temp\RunMe.pptm!RunMe", "This is the passed parameter"
oPres.Close
End Sub
Sub TestWithArray()
Dim sFileName As String
Dim oPres As Presentation
Dim aStrings(1 To 3) As String
sFileName = "C:\temp\runme.pptm"
Set oPres = Presentations.Open(sFileName, , , False)
aStrings(1) = "String 1"
aStrings(2) = "String 2"
aStrings(3) = "String 3"
Application.Run "C:\temp\RunMe.pptm!HowAboutAnArray", aStrings
oPres.Close
End Sub
And here are the macros they call:
Sub RunMe(sMsg As String)
MsgBox "You said " & sMsg
End Sub
Sub HowAboutAnArray(vParm As Variant)
Dim x As Long
For x = 1 To ubound(vParm)
MsgBox vParm(x)
Next
End Sub
Related
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
I have the following code to copy images from one workbook to another. The code opens the source workbook/sheet, copies the image then closes the workbook. This process repeats multiple times. Is there a more efficient way to do this? maybe bypassing the clipboard?
I only need to copy 1 image(named "Picture 4") and 2-3 cell values per source workbook/sheet. I have 7-8 source workbook.
Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\testWS1.xlsx", True, True)
Set srcWS = srcWB.Sheets("sheetwithimage")
srcWS.Pictures(4).Copy
dstWS.Range("B7").PasteSpecial
Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\testWS2.xlsx", True, True)
Set srcWS = srcWB.Sheets("sheetwithimage")
srcWS.Pictures(4).Copy
dstWS.Range("G8").PasteSpecial
So the fast solution is here:
Turn off Screen Updating and then turn it on again afterwards, I implemented some time measurement in my code to visualize this:
Option Explicit
Sub copy_images_original()
Dim dstWS As Worksheet
Set dstWS = ThisWorkbook.Sheets(1)
Dim srcWB As Workbook
Dim srcWS As Worksheet
Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\testWS1.xlsx", True, True)
Set srcWS = srcWB.Sheets("sheetwithimage")
srcWS.Pictures(4).Copy
dstWS.Range("B7").PasteSpecial
srcWB.Close
Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\testWS2.xlsx", True, True)
Set srcWS = srcWB.Sheets("sheetwithimage")
srcWS.Pictures(4).Copy
dstWS.Range("G8").PasteSpecial
srcWB.Close
End Sub
Sub CalculateRunTime_Seconds()
'PURPOSE: Determine how many seconds it took for code to completely run
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
Dim StartTime As Double
Dim SecondsElapsed As Double
'Remember time when macro starts
StartTime = Timer
'*****************************
Call turn_app_off
Call copy_images_original
Call turn_app_on
'*****************************
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
Sub turn_app_off()
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
End Sub
Sub turn_app_on()
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
What has now improved?
Your srcWBs will now be closed, your original source code didnt do that.
In my scenario here, the execution time improved from 2 Secs to 1,4 Secs.
So your Code runs 25% faster without much effort.
Hope you find my suggestion fair enough.
With best regards
Create a Report
I was assuming that the destination workbook and the workbook containing this code, ThisWorkbook, are the same.
Adjust the values in the constants section.
Run only the createReport procedure. The function getFilePathsInFolder is being called by it.
Since ThisWorkbook will not have an "xlsx" extension, the statement If StrComp(FilePaths(fp), dstFilePath, vbTextCompare) <> 0 Then is redundant, but I'm leaving it because you might one day change the file extension to "xls*" when the code could do some damage.
Abstract
It will look in the specified folder and write all .xlsx files to an array. It will loop through the array and open each workbook to copy the picture, specified by its index, and paste it and write the specified cell values, to the specified locations of the destination workbook, closing each source workbook afterwards.
The Code
Option Explicit
Sub createReport()
Const ProcName As String = "createReport"
On Error GoTo clearError
' Source
Const Extension As String = "xlsx"
Const srcName As String = "sheetwithimage"
Const srcList As String = "A1,A2,A3" ' add more
Const picIndex As Long = 1
' Destination
Const dstName As String = "Sheet1"
Const dstList As String = "B1,B2,B3" ' add more
Const picAddress As String = "B7"
Const colOffset As Long = 5
' Write file paths from Source Folder Path to File Paths array.
Dim wbDst As Workbook: Set wbDst = ThisWorkbook
Dim srcFolderPath As String: srcFolderPath = wbDst.Path
Dim FilePaths As Variant
FilePaths = getFilePathsInFolder(srcFolderPath, Extension)
Dim srcCells() As String: srcCells = Split(srcList, ",")
Dim dstCells() As String: dstCells = Split(dstList, ",")
' Use a variable for lower and upper if inside another loop.
' Split ensures that lower is 0, so no need for lower variable.
Dim CellsUB As Long: CellsUB = UBound(srcCells) ' or 'Ubound(dstCells)'
Dim dst As Worksheet: Set dst = wbDst.Worksheets(dstName)
Dim dstFilePath As String: dstFilePath = wbDst.FullName
' Declare new variables occurring in the following loop.
Dim wbSrc As Workbook
Dim src As Worksheet
Dim srcCount As Long
Dim fp As Long
Dim n As Long
Application.ScreenUpdating = False
' We don't care if 'FilePaths' is zero, one or five-based, since we
' cannot use fp because of 'ThisWorkbook'; hence 'srcCount'.
For fp = LBound(FilePaths) To UBound(FilePaths)
' We have to skip 'ThisWorkbook'. Using 'StrComp' with 'vbTextCompare'
' is a great way for comparing strings case-insensitively i.e. 'A=a'.
' '0' means it is a match.
If StrComp(FilePaths(fp), dstFilePath, vbTextCompare) <> 0 Then
Set wbSrc = Workbooks.Open(FilePaths(fp), True, True)
Set src = wbSrc.Worksheets(srcName)
src.Pictures(picIndex).Copy
dst.Range(picAddress).Offset(, srcCount * colOffset).PasteSpecial
For n = 0 To CellsUB ' 'Split'
dst.Range(dstCells(n)).Offset(, srcCount * colOffset).Value _
= src.Range(srcCells(n)).Value
Next n
wbSrc.Close SaveChanges:=False
srcCount = srcCount + 1
End If
Next fp
' Save and/or inform user.
If srcCount > 0 Then
dst.Range("A1").Select
wbDst.Save
Application.ScreenUpdating = True
If srcCount = 1 Then
MsgBox "Data from 1 workbook transferred.", vbInformation, "Success"
Else
MsgBox "Data from " & srcCount & " workbooks transferred.", _
vbInformation, "Success"
End If
Else
MsgBox "No matching workbooks found in folder '" & srcFolderPath _
& "'!", vbCritical, "Fail"
End If
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Sub
Function getFilePathsInFolder( _
FolderPath As String, _
Optional ByVal ExtensionPattern As String = "", _
Optional ByVal FirstIndex As Long = 0) _
As Variant
Const ProcName As String = "listFilePathsInFolder"
On Error GoTo clearError
With CreateObject("Scripting.FileSystemObject")
Dim fsoFolder As Object
Set fsoFolder = .GetFolder(FolderPath)
Dim FilesCount As Long
FilesCount = fsoFolder.Files.Count
If FilesCount > 0 Then
Dim n As Long
n = FirstIndex - 1
Dim OneD As Variant
ReDim OneD(FirstIndex To FilesCount + n)
Dim fsoFile As Object
If ExtensionPattern = "" Then
For Each fsoFile In fsoFolder.Files
n = n + 1
OneD(n) = fsoFile.Path
Next fsoFile
getFilePathsInFolder = OneD
Else
For Each fsoFile In fsoFolder.Files
If LCase(.GetExtensionName(fsoFile)) _
Like LCase(ExtensionPattern) Then
n = n + 1
OneD(n) = fsoFile.Path
End If
Next fsoFile
If n > FirstIndex - 1 Then
ReDim Preserve OneD(FirstIndex To n)
getFilePathsInFolder = OneD
Else
Debug.Print "'" & ProcName & "': " _
& "No '" & ExtensionPattern & "'-files found."
End If
End If
Else
Debug.Print "'" & ProcName & "': " _
& "No files found."
End If
End With
ProcExit:
Exit Function
clearError:
Debug.Print "'" & ProcName & "': Unexpected error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
I am having some issues adding my signature into the Adobe PDF. For some reason, I can't add my digital ID into the PDF using the additional code.
I keep on getting a Run-Time Error '13': Type Mismatch
Any suggestions?
I got the macro working so that it adds in the Signature field using the following code -
Sub Prepare_PDF()
On Error GoTo Err_Handler
Dim pdfPDDoc As New AcroPDDoc, oJS As Object, oFields, oAttachment As Object
Dim strFName As String
Dim strSignature As String
Dim strSignFName As String
Dim oParam As Parameter
strFName = "70145173 - 0100771347.pdf"
'------- Add signature fields to PDF file----------
If pdfPDDoc.Open(strFName) Then
Set oJS = pdfPDDoc.GetJSObject
Set oFields = oJS.AddField("SignatureField1", "signature", 0, Array(200, 620, 450, 670))
'------- Save PDF file------------------
strFName = Left(strFName, Len(strFName) - 4) & "-signed.pdf"
pdfPDDoc.Save 1, strFName
End If
Exit_Proc:
Exit Sub
Err_Handler:
MsgBox "In test" & vbCrLf & Err.Number & "--" & Err.Description
Resume Exit_Proc
End Sub
Now when I add this code in to get my digital ID added, it error's out.
Sub Prepare_PDF()
On Error GoTo Err_Handler
Dim pdfPDDoc As New AcroPDDoc, oJS As Object, oFields, oAttachment As Object
Dim strFName As String
Dim strSignature As String
Dim oPpklite As Object
Dim strSignFName As String
Dim oParam As Parameter
strFName = "A:\PDF File\Cost Transfer - 70145173 - 0100771347.pdf"
strSignature = "C:\Users\Desktop\FirstName.pfx"
'------- Add signature fields to PDF file----------
If pdfPDDoc.Open(strFName) Then
Set oJS = pdfPDDoc.GetJSObject
Set oFields = oJS.AddField("SignatureField1", "signature", 0, Array(200, 620, 450, 670))
Set oSign = oJS.GetField("SignatureField1")
Set oPpklite = oJS.security.getHandler("Adobe.PPKLite", True)
oPpklite.login "{'Password', '" & strSignature & "'}"
oSign.signatureSign oPpklite
oPpklite.logout
'------- Save PDF file------------------
strFName = Left(strFName, Len(strFName) - 4) & "-signed.pdf"
pdfPDDoc.Save 1, strFName
End If
Exit_Proc:
Exit Sub
Err_Handler:
MsgBox "In test" & vbCrLf & Err.Number & "--" & Err.Description
Resume Exit_Proc
End Sub
This is what works for me: i do the signing in two steps. (i did it in Access, but it should be almost the same for Excel)
Option Compare Database
Option Explicit
'the position of the signing box on the PDF
Const Y = 524
Const X = 14
Const W = 106
Const H = 59
Public Function PreparePDF(InputPDF As String) As Boolean
On Error GoTo Err_Handler
Dim pdfPDDoc As Acrobat.AcroPDDoc
Dim OutputPdf As String: OutputPdf = "C:\fact\Temp.pdf"
'it needs to be an array
Dim sg_arr() As Variant: sg_arr = Array(X, Y + H, X + W, Y)
Dim oJS As Object
Dim oPpklite As Object
Dim SignField As Object
Dim HadError As Boolean: HadError = False
Set pdfPDDoc = New AcroPDDoc
If pdfPDDoc.Open(InputPDF) Then
Set oJS = pdfPDDoc.GetJSObject
Set oPpklite = oJS.security.getHandler("Adobe.PPKLite")
'add the signature field to the PDF, then save and close. Otherwise,
'Acrobat will give the following message:
'"GeneralError: Operation failed. Field.signatureSign:0: This operation cannot be done before the document has finished downloading. Please try again later."
Set SignField = oJS.AddField("Sgn", "signature", 0, sg_arr)
pdfPDDoc.Save 1, OutputPdf
End If
Exit_Proc:
If Not oPpklite Is Nothing Then oPpklite.logout
Set oJS = Nothing
Set oPpklite = Nothing
Set pdfPDDoc = Nothing
If Not HadError Then
If SignPDF(InputPDF) Then
MsgBox "Successfully signed " & InputPDF & "!", vbOKOnly + vbInformation
Dim Fso As New FileSystemObject
Fso.DeleteFile "C:\fact\Temp.pdf", True
Set Fso = Nothing
PreparePDF = True
Else
PreparePDF = False
End If
Else
PreparePDF = False
End If
Exit Function
Err_Handler:
HadError = True
Debug.Print "In SignPDF" & vbCrLf & Err.Number & "--" & Err.Description
Resume Exit_Proc
End Function
Public Function SignPDF(OutputPdf As String) As Boolean '(inputpdf As String, outputpdf As String)
On Error GoTo Err_Handler
Dim InputPDF As String: InputPDF = "C:\fact\temp.pdf"
Dim strSignFName As String: strSignFName = "C:\fact\PFA.pfx"
Dim pass As String: pass = "******"
Dim pdfApp As Acrobat.AcroApp
Dim pdfPDDoc As Acrobat.AcroPDDoc
Dim oJS As Object
Dim oSign As Object
Dim oPpklite As Object
Dim ResultLogin As Boolean
Dim ResultSign As Boolean
Dim arr() As String
Set pdfApp = New AcroApp
Set pdfPDDoc = New AcroPDDoc
If pdfPDDoc.Open(InputPDF) Then
Set oJS = pdfPDDoc.GetJSObject
Set oPpklite = oJS.security.getHandler("Adobe.PPKLite")
ResultLogin = oPpklite.login(pass, "C:\fact\PFA.pfx")
oPpklite.setPasswordTimeout pass, 200
Set oSign = oJS.GetField("Sgn")
arr = VBA.Split("", ",")
ResultSign = oSign.signatureSign(oPpklite, arr, OutputPdf)
End If
SignPDF = True
Exit_Proc:
If Not oPpklite Is Nothing Then oPpklite.logout
If Not pdfApp Is Nothing Then
pdfApp.CloseAllDocs
pdfApp.Hide
pdfApp.Exit
End If
Set oJS = Nothing
Set oSign = Nothing
Set oPpklite = Nothing
Set pdfPDDoc = Nothing
Set pdfApp = Nothing
Exit Function
Err_Handler:
SignPDF = False
Debug.Print "In SignPDF" & vbCrLf & Err.Number & "--" & Err.Description
Resume Exit_Proc
End Function
And to call it:
PreparePDF "pdf_file_to_be_signed.pdf"
Obviously you need to reference acrobat.tlb
I'm trying to create a macro for a command button that when clicked, will get the job number from that row and look for a file for that job. If it does not exist I want it to copy from a template and save with a new name, otherwise just open the file.
However, I cannot seem to work out how to get hold of the information for the command button that calls the macro. This is what I have so far:
Public Function ShapeExists(OnSheet As Object, Name As String) As Boolean
On Error GoTo ErrShapeExists
If Not OnSheet.Shapes(Name) Is Nothing Then
ShapeExists = True
End If
ErrShapeExists:
Exit Function
End Function
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim buttonName As String
buttonName = (Target.Row - 1)
If Not ShapeExists(ActiveSheet, buttonName) Then
If Range("O" & Target.Row).Value = "" And Target.Column <= 14 And Target.Row > 1 Then
ActiveSheet.Buttons.Add(910.5, Range("O" & Target.Row).Top, 80, 20).Select
Selection.Name = buttonName
Selection.OnAction = "Sheet1.JobButton"
ActiveSheet.Shapes(buttonName).Select
Selection.Characters.Text = "Open Job"
End If
End If
End Sub
Private Sub JobButton()
Dim newText As String
ActiveSheet.Shapes(Application.Caller).Select
If Range("N" & Selection.TopLeftCell.Row).Value <> "" Then
newText = "Job " & Range("N" & Selection.TopLeftCell.Row).Value
Dim checkFilename As String
Dim check As String
check = "N" & Selection.TopLeftCell.Row
checkFilename = newText & ".xlsm"
If Dir(checkFilename) <> "" Then
Workbooks.Open (newText)
Else
Dim SrcBook As Workbook
Set SrcBook = ThisWorkbook
Dim NewBook As Workbook
NewBook = Workbooks.Open("Job Template.xlsm")
SrcBook.Worksheets(1).Range("D" & Selection.TopLeftCell.Row).Copy
NewBook.Worksheets(2).Range("B15").PasteSpecial
With NewBook
.Title = newText
.Subject = newText
.SaveAs Filename:=newText
End With
End If
Else
ErrMsg:
MsgBox ("Job Should always have a number."), , "NO JOB NUMBER"
End If
End Sub
As you can see I am currently trying ActiveSheet.Shapes(Application.Caller).Select, this is causing a "Run-time error '13': Type mismatch".
Any help would be much appreciated, thank you!
Right-click the button --> View Code --> put your JobButton code here
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