I have a macro code like
Do Until MyFileName = ""
Workbooks.Open Filename:=MyPath & MyFileName
ActiveWorkbook.SaveAs Filename:=Left(MyFileName, InStr(1, MyFileName, ".xls") - 1), FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbooks.CloseSaveChanges:=TRUE
MyFileName = Dir
Loop
Its working fine but while converting to csv the file is opening. I want to close the file and save changes is true. Please help me.
save the new name in a variable and use Workbook("name").close(true)
Dim wbName As String
Do Until MyFileName = ""
Workbooks.Open Filename:=MyPath & MyFileName
wbName = Left(MyFileName, InStr(1, MyFileName, ".xls") - 1)
ActiveWorkbook.SaveAs Filename:=wbName, FileFormat:=xlCSV, CreateBackup:=False
Workbooks(wbName).Close (True)
ActiveWorkbooks.Close SaveChanges:=True
MyFileName = Dir
Loop
End Sub
Related
I wrote code that saves the book in a specific format. After saving, the book is only available in read-only mode. What could be the error?
Sub SaveAs()
Application.DisplayAlerts = False
Dim relativePath As String
relativePath = ThisWorkbook.Path & "\" & ActiveWorkbook.Name
ActiveWorkbook.SaveAs Filename:=relativePath, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False, ReadOnlyRecommended:=False, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
Application.DisplayAlerts = True
End Sub
The following code loops through All files in a specified folder, formats each file, and saves it as a PDF in the same folder.
The code runs fine but there are 2 issues:
1)if there are any files in the folder that are already pdf,s it will open in and mess it up. How can I make this so it only opens the excel files in the folder and not PDF files?
2)if I run it twice it works but it just saves over files if the filename already exists. How can I make I so if when it saves it and the file name already exists it saves it as a new file like filename-b, filename-c filename-d, filename-f ect?
Sub File_Loop_Example()
Dim MyFolder As String, MyFile As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
MyFolder = .SelectedItems(1)
Err.clear
End With
MyFile = Dir(MyFolder & "\", vbReadOnly)
Do While MyFile <> ""
DoEvents
On Error GoTo 0
Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False
Application.Run "PERSONAL.XLSB!TTDA"
ChDir MyFolder
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
MyFolder & "\" & MyFile, Quality:= _
xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
0
Workbooks(MyFile).Close SaveChanges:=False
MyFile = Dir
Loop
End Sub
Try replacing of
MyFile = Dir(MyFolder & "\", vbReadOnly)
with
MyFile = Dir(MyFolder & "\" & "*.xlsx")
In this way, the code will open only .xlsx files.
Or you can let your code like it is, but filter the files to be open using the next function which retrieves the file extension:
Private Function GetExt(fileName As String) As String
GetExt = Split(fileName, ".")(UBound(Split(fileName, ".")))
End Function
The function can be called just before the workbook opening. Your loop will become something like this:
Do While MyFile <> ""
DoEvents
If GetExt(MyFile) = "xlsx" or GetExt(MyFile) = "xlsm" then
Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False
Application.Run "PERSONAL.XLSB!TTDA"
ChDir MyFolder
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
MyFolder & "\" & MyFile, Quality:= _
xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False
OpenAfterPublish:=True
Workbooks(MyFile).Close SaveChanges:=False
End if
MyFile = Dir
Loop
For the next issue, use please:
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(MyFolder & "\" & MyFile & ".pdf") Then
If fso.FileExists(MyFolder & "\" & MyFile & "_b.pdf") Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:= _
MyFolder & "\" & MyFile & "_a", Quality:= _
xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False
Else
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:= _
MyFolder & "\" & MyFile & "_b", Quality:= _
xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False
End If
Else
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:= _
MyFolder & "\" & MyFile, Quality:= _
xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False
End If
My goal is to open multiple excel files from input folder and convert them to .csv in output folder. I am facing minor issues where
code converts .xlsx to .csv , converts .xls to .csv but in output
folder, it stores .csv and .xls files. I can't figure out why .xls
files are also getting stored. I only wish to store .csv files
I only want to convert data from excel 'Sheet1' but the code is
converting data from an active sheet. How to specify to convert
data only from 'Sheet1'?
Option Explicit
Sub ImportMultipleCsvFile()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Dim InputCsvFile As Variant
Dim InputFolder As String, OutputFolder As String
InputFolder = "C:\Users\excel_format"
OutputFolder = "C:\Users\csv_format"
InputCsvFile = Dir(InputFolder & "\*.xl??")
While InputCsvFile <> ""
Workbooks.OpenText Filename:=InputFolder & "\" & InputCsvFile, DataType:=xlDelimited, Comma:=True
ActiveWorkbook.SaveAs Filename:=OutputFolder & "\" & Replace(ActiveWorkbook.Name, ".xlsx", ".csv"), FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.SaveAs Filename:=OutputFolder & "\" & Replace(ActiveWorkbook.Name, ".xls", ".csv"), FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
InputCsvFile = Dir
Wend
Application.Calculation = xlCalculationAutomatic
End Sub
If you change this:
ActiveWorkbook.SaveAs Filename:=OutputFolder & "\" & Replace(ActiveWorkbook.Name, ".xlsx", ".csv"), FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.SaveAs Filename:=OutputFolder & "\" & Replace(ActiveWorkbook.Name, ".xls", ".csv"), FileFormat:=xlCSV, CreateBackup:=False
to that:
--- to remove VBA codeblocks from Workbook before saving them as .csv, I have used this stackoverflow answer, then I checked it to make sense by using the info from here ---
Dim StartWb As Workbook
Dim TempWb As Workbook
Set StartWb = ActiveWorkbook
Set TempWb = Application.Workbooks.Add
StartWb.Worksheets("Sheet1").Copy Before:=TempWb.Worksheets(1)
If TempWb.Worksheets.Count > 1 Then
Do While (TempWb.Worksheets.Count > 1)
TempWb.Worksheets(TempWb.Worksheets.Count).Delete
Loop
End If
' ----- This is new to delete the codeblocks from your Sheets -----------
Dim Element As Object
For Each Element In TempWb.VBProject.VBComponents
'For Each Item In Element.Collection ' This For loop wasn't needed at the and but I forgot it in
Element.CodeModule.DeleteLines 1, Element.CodeModule.CountOfLines
'Next ' It has most likely thrown up Undeclared Variable error with Option Eplicit
Next
' -----------------------------------------------------------------------
If InStr(StartWb.Name, ".xlsx") Then
TempWb.SaveAs Filename:=OutputFolder & "\" & Replace(StartWb.Name, ".xlsx", ".csv"), FileFormat:=xlCSV, CreateBackup:=False
ElseIf InStr(StartWb.Name, ".xls") Then
TempWb.SaveAs Filename:=OutputFolder & "\" & Replace(StartWb.Name, ".xls", ".csv"), FileFormat:=xlCSV, CreateBackup:=False
End If
TempWb.Close (xlNo)
then you will only get your .csv file saved, as well as it will only contain that first sheet.
I would also put these:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
at the end of your code before or after:
Application.Calculation = xlCalculationAutomatic
Also swap this:
ActiveWorkbook.Close
to that:
StartWb.Close (xlNo)
To remove code from workbooks by code you have to change settings in Excel:
I'm converting CSVs to XLSMs using a new temporary file with the following SUB.
sub a()
j=array("apple","orange")
for each i in j
workbooks.open environ("userprofile") & "\desktop\" & i & ".csv"
activeworkbook.saveas environ("userprofile") & "\desktop\" & i & ".xlsm", xlopenxmlworkbookmacroenabled
activeworkbook.close
next i
end sub
I wonder whether I can include this SUB to each of the new XLSMs. Thanks.
When I use the following code to:
save a macro-enabled workbook
in the same folder as the open workbook
it does save the file with the wrong name and on the desktop:
Sub Save_New_MacroEnabledFile()
Dim thisWb As Workbook
Set thisWb = ActiveWorkbook
Worksheets("Sheet_with_VBA_Button").Activate
ActiveWorkbook.SaveAs Filename:=thisWb.Path & Sheets("Sheet_with_NewFile's_Name").Range("A2"), FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, Password:=vbNullString, WriteResPassword:=vbNullString, _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub
What am I doing wrong?
You didn't add slash when you creating new filepath.
Probably the folder where you have this file is on the desktop and without slash it just append the name of the file to the name of the folder, i.e.
folder was:
C:\Users\Antoine\Desktop\Folder
and after appending the filename without slash it was like:
C:\Users\Antoine\Desktop\Folderfilename.xlsx
Try this code:
Sub Save_New_MacroEnabledFile()
Dim thisWb As Workbook
Dim fileName As String
Set thisWb = ActiveWorkbook
Worksheets("Sheet_with_VBA_Button").Activate
Application.DisplayAlerts = False
fileName = thisWb.Path & "\" & Sheets("Sheet_with_NewFile's_Name").Range("A2") & VBA.IIf(Right(fileName, 5) = ".xlsm", "", ".xlsm")
ActiveWorkbook.SaveAs fileName:=fileName, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:=vbNullString, WriteResPassword:=vbNullString, _
ReadOnlyRecommended:=False, CreateBackup:=False
Application.DisplayAlerts = True
End Sub