I have this code.
This code converts to xlsm files.
I want to convert to xlsx files.
How?
I tried by changing
wBook.SaveAs XlsFolder & Replace(fname, ".csv", ""), ThisWorkbook.FileFormatTO
wBook.SaveAs XlsFolder & Replace(fname, ".csv", ".xlsx")
It didn't worked.
Private Sub CommandButton2_Click()
Dim CSVfolder As String
Dim XlsFolder As String
Dim fname As String
Dim wBook As Workbook
CSVfolder = "C:\csv\"
XlsFolder = "C:\Charts\"
fname = Dir(CSVfolder & "*.csv")
Do While fname <> ""
Set wBook = Workbooks.Open(CSVfolder & fname, Format:=6, Delimiter:=",")
wBook.SaveAs XlsFolder & Replace(fname, ".csv", ""), ThisWorkbook.FileFormat
wBook.Close False
fname = Dir
Loop
End Sub
Using the macro recoder, the file format for an xlsx workbook is FileFormat:=xlOpenXMLWorkbook
So here is your code :
Private Sub CommandButton2_Click()
Dim CSVfolder As String, _
XlsFolder As String, _
fname As String, _
wBook As Workbook
CSVfolder = "C:\csv\"
XlsFolder = "C:\Charts\"
fname = Dir(CSVfolder & "*.csv")
Do While fname <> ""
Set wBook = Workbooks.Open(CSVfolder & fname, Format:=6, Delimiter:=",")
wBook.SaveAs XlsFolder & Replace(fname, ".csv", ""), xlOpenXMLWorkbook
wBook.Close False
fname = Dir
Loop
End Sub
Related
Why am I getting object not set error? Seems to be on this line with debug?
xlsmTarget.VBProject.VBComponents.Import "C:\New Name Test\Testv3\CreateUniqueContainers.bas"
However target seems to be set, what have I done wrong?
Sub ConvertXLSFilesToXLSM()
Dim Path As String
Dim DestPath As String
Dim xlsmTarget As Workbook
Const ModulePath As String = "C:\New Name Test\Testv3\CreateUniqueContainers.bas"
Path = "C:\New Name Test\Testv3\Files\"
DestPath = "C:\New Name Test\Testv3\Files\"
WorkFile = Dir(myPath & "*.xls")
Do While WorkFile <> ""
If Right(WorkFile, 4) <> "xlsm" Then
Workbooks.Open Filename:=Path & "\" & WorkFile
ActiveWorkbook.SaveAs Filename:= _
DestPath & WorkFile & ".xlsm",
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
xlsmTarget.VBProject.VBComponents.Import ModulePath
ActiveWorkbook.Save
ActiveWorkbook.Close
End If
WorkFile = Dir()
Loop
End Sub
Option Explicit
Sub ConvertXLSFilesToXLSM()
Const FOLDER = "C:\New Name Test\Testv3\"
Const MODNAME = "CreateUniqueContainers.bas"
Dim SrcPath As String, DestPath As String
Dim SrcFile As String, DestFile As String
Dim n As Long
SrcPath = FOLDER & "Files\"
DestPath = FOLDER & "Files\"
SrcFile = Dir(SrcPath & "*.xls*")
Do While SrcFile <> ""
If Right(SrcFile, 4) <> "xlsm" Then
Debug.Print SrcFile
Workbooks.Open Filename:=SrcPath & "\" & SrcFile
' replace .xls or .xlsx with .xlsm
DestFile = DestPath & Split(SrcFile, ".")(0) & ".xlsm"
' save with new name
With ActiveWorkbook
.SaveAs Filename:=DestFile, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
CreateBackup:=False
' import module and save
.VBProject.VBComponents.Import FOLDER & MODNAME
.Save
.Close
End With
n = n + 1
End If
SrcFile = Dir()
Loop
MsgBox n & " files created", vbInformation
End Sub
You need to actually set your variable, and use it. Also, don't rely on Active*
Sub ConvertXLSFilesToXLSM()
Dim Path As String
Dim DestPath As String
Dim xlsmTarget As Workbook
Const ModulePath As String = "C:\New Name Test\Testv3\CreateUniqueContainers.bas"
Path = "C:\New Name Test\Testv3\Files\"
DestPath = "C:\New Name Test\Testv3\Files\"
WorkFile = Dir(Path & "*.xls")
Do While WorkFile <> ""
If Right(WorkFile, 4) <> "xlsm" Then
Set xlsmTarget = Workbooks.Open(Path & WorkFile)
xlsmTarget.SaveAs _
Filename:=DestPath & replace(WorkFile, ".xls", ".xlsm"), _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
CreateBackup:=False
xlsmTarget.VBProject.VBComponents.Import ModulePath
'xlsmTarget.Save
xlsmTarget.Close, True
End If
WorkFile = Dir()
Loop
End Sub
I would like to:
open all .csv files in the same folder.
save a copy each in .xlsx format.
with the .xlsx format file name as the Range(“B1”).Value from the corresponding .csv file.
Here is my code so far (not working):
Dim MyFolderPath As String
MyFolderPath = Application.DefaultFilePath
myFolderPath = Application.DefaultFilePath
MyFileName = Dir(myFolderPath & "\" & "*.csv")
While MyFileName <> ""
Set CSVWorkbook = Workbooks.Open(myFolderPath & "\" & MyFileName)
CSVWorkbook.SaveCopyAs Filename:=myFolderPath & "\" & CSVWorkbook.Sheets(1).Range("B1").Value & ".xlsx"
CSVWorkbook.Close SaveChanges:=False
Wend
Could anyone help me to identify the issue?
Many thanks!
Hello TropicalMagic...
try this
`Sub test()
Dim MyFolderPath As String
Dim CSVworkbook As Workbook
Dim MyfileName As Variant
Dim NewFilename As String
MyFolderPath = Application.DefaultFilePath
MyfileName = Dir(MyFolderPath & "\" & "*.csv")
While MyfileName <> ""
Set CSVworkbook = Workbooks.Open(MyFolderPath & "\" & MyfileName)
NewFilename = CSVworkbook.Sheets(1).Range("B1").Text
CSVworkbook.SaveCopyAs fileName:=MyFolderPath & "\" & NewFilename & ".xlsx"
CSVworkbook.Close SaveChanges:=False
MyfileName = Dir
Wend
End Sub`
Another point to mention. Ensure you have data in the Sheets(1) "b1" range.
If you open an empty CSV in excel and put something in B1, Save it and reopen and you will see the text in B1 will have moved to A1 due to the way excel interprets CSV's and there being no control or delimiters in an empty CSV Spread sheet. To get around this put something in A1.
Thanks for responding! I have found a solution as well:
Dim MyFolderPath As String
Dim CSVworkbook As Workbook
Dim MyFileName As Variant
Dim NewFileName As String
MyFolderPath = Application.DefaultFilePath
MyFileName = Dir(MyFolderPath & "\" & "*.csv")
While MyFileName <> ""
Set CSVworkbook = Workbooks.Open(MyFolderPath & "\" & MyFileName)
NewFileName = CSVworkbook.Sheets(1).Range("B1").Text
CSVworkbook.SaveAs MyFolderPath & "\" & NewFileName & ".xlsx", xlOpenXMLWorkbook
CSVworkbook.Close SaveChanges:=False
MyFileName = Dir
Wend
Cheers
How do I remove the last empty line that the VBA creates when you save a sheet to a csv?
Sub SaveAsCSV()
Dim strSourceSheet As String
Dim strFullname As String
strSourceSheet = "Sheet1"
strFullname = "\\H:\filepath\filepath1\"
myfilenamedate = Format(Range("C2"), "yyyyMMdd")
myfilenameindicator = "data"
ThisWorkbook.Sheets(strSourceSheet).Copy
ActiveWorkbook.SaveAs Filename:=strFullname & myfilenameindicator & myfilenamedate & ".csv", _
FileFormat:=xlCSV, _
CreateBackup:=True, _
local:=True
ActiveWorkbook.Close
End Sub
I have updated the code to #FaneDuru's specification and when this code is expressed in this manner it still returns an error. If someone can assist it helping understand what is happening it would be much appreciated. My VBA understanding is quite limited.
Sub SaveAsCSV()
Function eliminateEmptyRow(fullName As String) As Boolean
'Necessary a reference to "Microsoft Script Control 1.0"
Dim fso As New FileSystemObject, txtStr As TextStream, objOutputFile As TextStream, strText As String
If Dir(fullName) <> "" Then 'check if file exists
Set txtStr = fso.OpenTextFile(fullName)
strText = txtStr.ReadAll
txtStr.Close
Else
eliminateEmptyRow = False: Exit Function
End If
strText = left(strText, Len(strText) - 2)
Set objOutputFile = fso.CreateTextFile(fullName)
objOutputFile.Write strText
objOutputFile.Close
eliminateEmptyRow = True
End Function
Dim strSourceSheet As String
Dim strFullname As String
strSourceSheet = "Sheet1"
strFullname = "\\H:\filepath\filepath1\"
myfilenamedate = Format(Range("C2"), "yyyyMMdd")
myfilenameindicator = "data"
ThisWorkbook.Sheets(strSourceSheet).Copy
ActiveWorkbook.SaveAs Filename:=strFullname & myfilenameindicator & myfilenamedate & ".csv", _
FileFormat:=xlCSV, _
CreateBackup:=True, _
local:=True
ActiveWorkbook.Close
If Not eliminateEmptyRow(strFullname & myfilenameindicator & myfilenamedate & ".csv") Then Stop
End Sub
Try please the next approach. Naturally Excel inserts an empty line to append if you need that. The next function should open the created file and should eliminate the VbCrLf from the end:
Function eliminateEmptyRow(fullName As String) As Boolean
'Necessary a reference to "Microsoft Script Control 1.0"
Dim fso As New FileSystemObject, txtStr As TextStream, objOutputFile As TextStream, strText As String
If Dir(fullName) <> "" Then 'check if file exists
Set txtStr = fso.OpenTextFile(fullName)
strText = txtStr.ReadAll
txtStr.Close
Else
eliminateEmptyRow = False: Exit Function
End If
strText = left(strText, Len(strText) - 2)
Set objOutputFile = fso.CreateTextFile(fullName)
objOutputFile.Write strText
objOutputFile.Close
eliminateEmptyRow = True
End Function
Insert the next line after ActiveWorkbook.Close:
If Not eliminateEmptyRow(strFullname & myfilenameindicator & myfilenamedate & ".csv") Then Stop
Test it, please and send some feedback.
Edited, to include the function call in the original code:
Sub SaveAsCSV()
Dim strSourceSheet As String
Dim strFullname As String
strSourceSheet = "Sheet1"
strFullname = "\\H:\filepath\filepath1\"
myfilenamedate = Format(Range("C2"), "yyyyMMdd")
myfilenameindicator = "data"
ThisWorkbook.Sheets(strSourceSheet).Copy
ActiveWorkbook.SaveAs Filename:=strFullname & myfilenameindicator &
myfilenamedate & ".csv", _
FileFormat:=xlCSV, _
CreateBackup:=True, _
local:=True
ActiveWorkbook.Close
If Not eliminateEmptyRow(strFullname & myfilenameindicator & myfilenamedate & ".csv") Then Stop
End Sub
By clicking a button in Excel, the user exports a specific sheet to a csv with a dynamic filename and the csv is saved in a pre-determined directory.
Instead of saving to a predetermined directory, can users have the browse window to choose a directory to save to?
Sub Export()
Dim MyPath As String
Dim MyFileName As String
MyPath = "C:\importtest"
MyFileName = "MR_Update_" & Sheets("Monthly Review").Range("D3").Value & "_" & Format(Date, "ddmmyyyy")
If Not Right(MyPath, 1) = "\" Then MyPath = MyPath & "\"
If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
Sheets("Export Data").Copy
With ActiveWorkbook
.SaveAs Filename:= _
MyPath & MyFileName, _
FileFormat:=xlCSV, _
CreateBackup:=False
.Close False
End With
End Sub
Excel has an inbuilt FileSave Dialog. It is called .GetSaveAsFilename. Use that.
Syntax
expression.GetSaveAsFilename(InitialFilename, FileFilter, FilterIndex, Title, ButtonText)
Usage
Dim fileSaveName As Variant
fileSaveName = Application.GetSaveAsFilename( _
fileFilter:="Excel Files (*.csv), *.csv")
If fileSaveName <> False Then
'
'~~> Your code to save the file here
'
End If
As Patrick suggested, you're looking for the .FileDialog property.
To implement it, try this:
Sub Export()
Dim MyPath As String
Dim MyFileName As String
MyFileName = "MR_Update_" & Sheets("Monthly Review").Range("D3").Value & "_" & Format(Date, "ddmmyyyy")
If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
Sheets("Export Data").Copy
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = "" '<~~ The start folder path for the file picker.
If .Show <> -1 Then GoTo NextCode
MyPath = .SelectedItems(1) & "\"
End With
NextCode:
With ActiveWorkbook
.SaveAs Filename:=MyPath & MyFileName, FileFormat:=xlCSV,CreateBackup:=False
.Close False
End With
End Sub
Try This......
Sub Export()
Dim MyPath As String
Dim MyFileName As String
MyPath = "C:\importtest"
MyFileName = "MR_Update_" & Sheets("Monthly Review").Range("D3").Value & "_" & Format(Date, "ddmmyyyy")
If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
Sheets("Export Data").Copy
With ActiveWorkbook
.SaveAs Filename:= _
MyFileName, _
FileFormat:=xlCSV, _
CreateBackup:=False
.Close False
End With
End Sub
Here's a script I've been using lately that I like a lot. Thought I would leave this here:
Sub ExportCSV()
Dim FlSv As Variant
Dim MyFile As String
Dim sh As Worksheet
Dim MyFileName As String
Dim DateString As String
DateString = Format(Now(), "yyyy-mm-dd_hh_mm_ss_AM/PM") '<~~ uses current time from computer clock down to the second
MyFileName = DateString & "_" & "Whatever you like"
Set sh = Sheets("Sheet you'd like to export")
sh.Copy
FlSv = Application.GetSaveAsFilename(MyFileName, fileFilter:="CSV (Comma delimited) (*.csv), *.csv", Title:="Where should we save this?")
If FlSv = False Then GoTo UserCancel Else GoTo UserOK
UserCancel: '<~~ this code is run if the user cancels out the file save dialog
ActiveWorkbook.Close (False)
MsgBox "Export canceled"
Exit Sub
UserOK: '<~~ this code is run if user proceeds with saving the file (clicks the OK button)
MyFile = FlSv
With ActiveWorkbook
.SaveAs (MyFile), FileFormat:=xlCSV, CreateBackup:=False
.Close False
End With
End Sub
i have bunch of files in folder all of them are in xlsx format, I need to convert them to xls format. This is going to be done on daily bases.
I need a macro which will loop around the folder and convert the file to xls from xlsx with out changing file name.?
Here is the macro I am using to loop
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "C:\Users\myfolder1\Desktop\myfolder\Macro\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
DoWork wb
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End Sub
What you are missing is that instead of calling wb.Close SaveChanges=True to save the file in another format, you need to call wb.SaveAs with the new file format and name.
You said you want to convert them without changing the file name, but I suspect you really meant you want to save them with the same base file name, but with the .xls extension. So if the workbook is named book1.xlsx, you want to save it as book1.xls. To calculate the new name you can do a simple Replace() on the old name replacing the .xlsx extension with .xls.
You can also disable the compatibility checker by setting wb.CheckCompatibility, and suppress alerts and messages by setting Application.DisplayAlerts.
Sub ProcessFiles()
Dim Filename, Pathname, saveFileName As String
Dim wb As Workbook
Dim initialDisplayAlerts As Boolean
Pathname = "<insert_path_here>" ' Needs to have a trailing \
Filename = Dir(Pathname & "*.xlsx")
initialDisplayAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
Do While Filename <> ""
Set wb = Workbooks.Open(Filename:=Pathname & Filename, _
UpdateLinks:=False)
wb.CheckCompatibility = False
saveFileName = Replace(Filename, ".xlsx", ".xls")
wb.SaveAs Filename:=Pathname & saveFileName, _
FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
wb.Close SaveChanges:=False
Filename = Dir()
Loop
Application.DisplayAlerts = initialDisplayAlerts
End Sub
Sub SaveAllAsXLSX()
Dim strFilename As String
Dim strDocName As String
Dim strPath As String
Dim wbk As Workbook
Dim fDialog As FileDialog
Dim intPos As Integer
Dim strPassword As String
Dim strWritePassword As String
Dim varA As String
Dim varB As String
Dim colFiles As New Collection
Dim vFile As Variant
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = "Select folder and click OK"
.AllowMultiSelect = True
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User", , "List Folder Contents"
Exit Sub
End If
strPath = fDialog.SelectedItems.Item(1)
If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
End With
If Left(strPath, 1) = Chr(34) Then
strPath = Mid(strPath, 2, Len(strPath) - 2)
End If
Set obj = CreateObject("Scripting.FileSystemObject")
RecursiveDir colFiles, strPath, "*.xls", True
For Each vFile In colFiles
Debug.Print vFile
strFilename = vFile
varA = Right(strFilename, 3)
If (varA = "xls" Or varA = "XLS") Then
Set wbk = Workbooks.Open(Filename:=strFilename)
If wbk.HasVBProject Then
wbk.SaveAs Filename:=strFilename & "m", FileFormat:=xlOpenXMLWorkbookMacroEnabled
Else
wbk.SaveAs Filename:=strFilename & "x", FileFormat:=xlOpenXMLWorkbook
End If
wbk.Close SaveChanges:=False
obj.DeleteFile (strFilename)
End If
Next vFile
End Sub
Public Function RecursiveDir(colFiles As Collection, _
strFolder As String, _
strFileSpec As String, _
bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function