I have this VBA code to convert CSV to XLSX, which seems to work but output Excel have strange strings like "Aço" and "plástico" instead of "Aço" or "plástico". I think solution is to include "Unicode UTF-8", but I couldn't find a way. Any help would be appreciated.
Sub CSVtoXLSX()
Dim xFd As FileDialog
Dim xSPath As String
Dim xCSVFile As String
Dim xWsheet As String
Application.DisplayAlerts = False
Application.StatusBar = True
xWsheet = ActiveWorkbook.Name
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
xFd.Title = "Select a folder:"
If xFd.Show = -1 Then
xSPath = xFd.SelectedItems(1)
Else
Exit Sub
End If
If Right(xSPath, 1) <> "\" Then xSPath = xSPath + "\"
xCSVFile = Dir(xSPath & "*.csv")
Do While xCSVFile <> ""
Application.StatusBar = "Converting: " & xCSVFile
Workbooks.Open Filename:=xSPath & xCSVFile
ActiveWorkbook.SaveAs Replace(xSPath & xCSVFile, ".csv", ".xlsx", vbTextCompare), xlWorkbookDefault
ActiveWorkbook.Close
Windows(xWsheet).Activate
xCSVFile = Dir
Loop
Application.StatusBar = False
Application.DisplayAlerts = True
End Sub
Related
I'm trying to use a macro I found online to save each doc from a mail merge into an individual PDF. But the macro does nothing. (never used macros before or VB) I tried stepping through the code and I get .DataSource.RecordCount = -1.
I can see the previewed documents, so the datasource is there. I figure there is something wrong with how it's getting the count value.
Any help is appreciated.
This is the whole macro:
Sub Merge_To_Individual_Files()
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
Application.ScreenUpdating = False
Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Set MainDoc = ActiveDocument
With MainDoc
StrFolder = .Path & "\"
With .MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
On Error Resume Next
For i = 1 To .DataSource.RecordCount
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Last_Name")) = "" Then Exit For
'StrFolder = .DataFields("Folder") & "\"
StrName = .DataFields("key")
End With
On Error GoTo NextRecord
.Execute Pause:=False
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
With ActiveDocument
'Add the name to the footer
'.Sections(1).Footers(wdHeaderFooterPrimary).Range.InsertBefore StrName
.SaveAs FileName:=StrFolder & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
.SaveAs FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
NextRecord:
Next i
End With
End With
Application.ScreenUpdating = True
End Sub
I am trying to make a copy of a workbook that I have, based on list of IDs. I have got this to work OK if I hard code the path, however I can't figure out how to do this where specifying the path using msoFileDialogFolderPicker.
I have tried a number of variations depending on what I have found online and have got as far as below but stuck. Help appreciated.
Dim xFilepath As Variant
Dim xFilename As String
xFilepath = Application.FileDialog(msoFileDialogFolderPicker)
xFilename = Range("Table9[ProgramID]") & " Product Financial Allocation" & ".xlsb"
With xFilepath
.Title = "Choose Destination"
.SHOW
mypath = .SelectedItems(1) & "\"
End With
mypath = mypath
Sheets("FILES").Range("A3").Select
For i = 1 To 3
Sheets("FILES").Range("A" & i).copy Sheets("TEMPLATE").Range("Table9[ProgramID]")
ActiveWorkbook.SaveCopyAs Filename:=mypath & Filename
FileFormat = 50
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Workbooks.Open Filename:=mypath & Filename
Call DeleteQueries
ActiveWorkbook.Save
ActiveWorkbook.Close
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
You can use the following code can be used to select folder and then you can append the folder path with file name.
Sub ChooseFolder()
Dim sFolder As String
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
If .Show = -1 Then ' if OK is pressed
sFolder = .SelectedItems(1)
End If
End With
Filename = "Test.xlsx"
Filepath = sFolder + "\" + Filename
If sFolder <> "" Then ' if a file was chosen
MsgBox Filepath 'Use this for further processing
End If
End Sub
Following code can be used select single file.
Private Sub ChooseFile()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Please select the file."
.Filters.Clear
.Filters.Add "Excel File", "*.xlsx"
If .Show = True Then
txtFileName = .SelectedItems(1) 'replace txtFileName with your textbox
End If
End With
MsgBox txtFileName
End Sub
My code keeps bugging at
.SaveAs FileName:=Pth, FileFormat:=xlCSV
I'm working on a MAC, but its supposed to be working on both Mac and windows, Does anybody know how to fix this? :)
Sub Opgave8()
Dim sh As Worksheet
Dim user_id As String
Dim file_name As String
Dim Pth As String
Dim overwrite_question As Integer
Dim i As Integer
Application.ScreenUpdating = False
user_id = Environ$("USERPROFILE")
file_name = "AdminExport.csv"
' Pth = user_id & "\Desktop\" & file_name
Pth = user_id & Application.PathSeparator & "Desktop" & Application.PathSeparator & file_name
Set sh = Sheets.Add
For i = 2 To 18288
If Left(Worksheets("Base").Cells(i, 12), 6) = "262015" Then
sh.Cells(i, 2) = Worksheets("Base").Cells(i, 4)
End If
Next i
sh.Move
overwrite_question = vbNo
If Dir(Pth) <> "" Then
overwrite_question = MsgBox("File already exist, do you want to overwrite it?", vbYesNo)
Else
With ActiveWorkbook
.SaveAs FileName:=Pth, FileFormat:=xlCSV
.Close
End With
End If
If overwrite_question = vbYes Then
Application.DisplayAlerts = False
With ActiveWorkbook
.SaveAs FileName:=Pth, FileFormat:=xlCSV
.Close False
End With
Application.DisplayAlerts = True
End If
Application.ScreenUpdating = True
End Sub
Function UniqueRandDigits(x As Long) As String
Dim i As Long
Dim n As Integer
Dim s As String
Do
n = Int(Rnd() * 10)
If InStr(s, n) = 0 Then
s = s & n
i = i + 1
End If
Loop Until i = x + 1
UniqueRandDigits = s
End Function
That path won't work on a Mac. You should use something like this:
Pth = user_id & Application.Pathseparator & "Desktop" & Application.Pathseparator & file_name
I need to turn a batch of pptm files into pptx. I tried to repurpose VBA code that turns xlsx files into xls files. The macro opens an xlsx file in a designated folder, saves it as an xls file, closes it, and moves on to the next file until all are converted. The original macro code was:
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
I modified it in the following way:
Sub ProcessFiles()
Dim Filename, Pathname, saveFileName As String
Dim ppPres As Presentation
Dim initialDisplayAlerts As Boolean
Pathname = "\\TRIFS03\RoamingProfiles\user\Documents\projectfolder\testfolder\" ' Needs to have a trailing \
Filename = Dir(Pathname & "*.pptm")
initialDisplayAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
Do While Filename <> ""
Set ppPres = Presentations.Open(Filename:=Pathname & Filename, _
UpdateLinks:=False)
ppPres.CheckCompatibility = False
saveFileName = Replace(Filename, ".pptm", ".pptx")
ppPres.SaveAs Filename:=Pathname & saveFileName, _
FileFormat:=ppSaveAsOpenXMLPresentation, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ppPres.Close SaveChanges:=False
Filename = Dir()
Loop
Application.DisplayAlerts = initialDisplayAlerts
End Sub
I get
Compile Error Named Argument Not Found
pointing to UpdateLinks:=.
I did some research and found that I should delete this bit of code. I was left with the following:
Sub ProcessFiles()
Dim Filename, Pathname, saveFileName As String
Dim ppPres As Presentation
Dim initialDisplayAlerts As Boolean
Pathname = "\\TRIFS03\RoamingProfiles\user\Documents\projectfolder\testfolder\" ' Needs to have a trailing \
Filename = Dir(Pathname & "*.pptm")
initialDisplayAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
Do While Filename <> ""
Set ppPres = Presentations.Open(Filename:=Pathname & Filename)
ppPres.CheckCompatibility = False
saveFileName = Replace(Filename, ".pptm", ".pptx")
ppPres.SaveAs Filename:=Pathname & saveFileName, _
FileFormat:=ppSaveAsOpenXMLPresentation, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ppPres.Close SaveChanges:=False
Filename = Dir()
Loop
Application.DisplayAlerts = initialDisplayAlerts
End Sub
I got
Compile Error Method or Data Member not Found
pointing to .CheckCompatability =.
I tried deleting THAT one.
Compile Error Named Argument Not Found
pointing to Password:=.
I decided to look for a new macro:
With ActivePresentation
.SaveCopyAs _
FileName:=.Path & "\" & Left(.Name, InStrRev(.Name, ".")) & "pptx", _
FileFormat:=ppSaveAsOpenXMLPresentation
End With
I added loop code and ended up with:
Sub ProcessFiles()
Dim Filename, FileFormat As String
Dim initialDisplayAlerts As Boolean
initialDisplayAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
Do While Filename <> ""
.SaveCopyAs _
Filename:=.Path & "\" & Left(.Name, InStrRev(.Name, ".")) & "pptx", _
FileFormat:=ppSaveAsOpenXMLPresentation
ppPres.Close SaveChanges:=False
Filename = Dir()
Loop
Application.DisplayAlerts = initialDisplayAlerts
End Sub
Which ended up with
Compile Error Invalid or Unqualified Reference
with .Path being pointed to as the culprit.
According to the code’s author (see top voted answer), I shouldn’t need to define .Path if I’m using \.
Something like:
Sub ProcessFiles()
Dim Filename, FileFormat As String
Dim initialDisplayAlerts As Boolean
initialDisplayAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
With ActivePresentation
Do While Filename <> ""
.SaveCopyAs _
Filename:=.Path & "\" & Left(.Name, InStrRev(.Name, ".")) & "pptx", _
FileFormat:=ppSaveAsOpenXMLPresentation
Filename = Dir()
Loop
End With
Application.DisplayAlerts = initialDisplayAlerts
End Sub
Thanks in advance for your help and comments.
I have the following problem, but I do not know if it is possible ... I am trying to rename PDF files that are in the folder C: \ ... I need to rename according to a worksheet that I have in excel that is ordered according to the pdf files .. I would like to rename with the spreadsheet data in excel?
I have a code that I researched but it does not search my database, but it asks me to enter the name of each file
Public Sub lsSelecionaArquivo()
Dim Caminho As String
Dim NomeBase As String
Caminho = InputBox("Informe o local dos arquivos a serem renomeados:", "Pasta", "C:\TEMP")
NomeBase = InputBox("Informe o local dos arquivos a serem renomeados:", "Renomear", "")
lsRenomearArquivos Caminho, NomeBase
End Sub
Public Sub lsRenomearArquivos(Caminho As String, NomeBase As String)
Dim FSO As Object, Pasta As Object, Arquivo As Object, Arquivos As Object
Dim Linha As Long
Dim lSeq As Long
Dim lNovoNome As String
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FolderExists(Caminho) Then
MsgBox "A pasta '" & Caminho & "' não existe.", vbCritical, "Erro"
Exit Sub
End If
lSeq = 1
Set Pasta = FSO.GetFolder(Caminho)
Set Arquivos = Pasta.Files
Cells(1, 1) = "De"
Cells(1, 2) = "Para"
Linha = 2
For Each Arquivo In Arquivos
Cells(Linha, 1) = UCase$(Arquivo.Path)
lNovoNome = Caminho & "\" & NomeBase & lSeq & Right(Arquivo, 4)
Name Arquivo.Path As lNovoNome
Cells(Linha, 2) = lNovoNome
lSeq = lSeq + 1
Linha = Linha + 1
Next
End Sub
For the renaming part, consider this.
Sub RenameFiles()
'Updateby20141124
Dim xDir As String
Dim xFile As String
Dim xRow As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
xDir = .SelectedItems(1)
xFile = Dir(xDir & Application.PathSeparator & "*")
Do Until xFile = ""
xRow = 0
On Error Resume Next
xRow = Application.Match(xFile, Range("A:A"), 0)
If xRow > 0 Then
Name xDir & Application.PathSeparator & xFile As _
xDir & Application.PathSeparator & Cells(xRow, "B").Value
End If
xFile = Dir
Loop
End If
End With
End Sub
https://www.extendoffice.com/documents/excel/2339-excel-rename-files-in-a-folder.html
Also, consider this.
Sub ListFiles()
Dim MyFolder As String
Dim MyFile As String
Dim j As Integer
MyFolder = "C:\DealerExam"
MyFile = Dir(MyFolder & "\*.*")
a = 0
Do While MyFile <> ""
a = a + 1
Cells(a, 1).Value = MyFile
MyFile = Dir
Loop
End Sub
This will list all the files in your directory starting in cell 'A1'
Thanks for the help
It is a bit tense to change language since I study Java and started doing VBA.
When I ran the code, I saw that it is necessary for the spreadsheet to have the old file name and the new one to insert the data, but there is no way to get it to just get the new data? And I've tried searching on how to make them as PDF without having to put the file extension in the worksheet.
Sorry for the questions ... I do not have much contact with VBA.
I thank you very much for helping me.
Sub RenameFiles()
Dim xDir As String
Dim xFile As String
Dim xRow As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
xDir = .SelectedItems(1)
xFile = Dir(xDir & Application.PathSeparator & "*")
Do Until xFile = ""
xRow = 0
On Error Resume Next
xRow = Application.Match(xFile, Range("A:A"), 0)
If xRow > 0 Then
Name xDir & Application.PathSeparator & xFile As _
xDir & Application.PathSeparator & Cells(xRow, "B").Value
End If
xFile = Dir
Loop
End If
End With
End Sub
Sub ListFiles()
Dim MyFolder As String
Dim MyFile As String
Dim j As Integer
MyFolder = "C:\Users\AnaWill\Desktop\Holerites Folha\Nova pasta"
MyFile = Dir(MyFolder & "\*.*")
a = 0
Do While MyFile <> ""
a = a + 1
Cells(a, 2).Value = MyFile
MyFile = Dir
Loop
End Sub