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
Related
How do I specifically extract the name from a PDF (screenshot as shown below) and rename the PDF as the name? So in this case, I want to extract Daniel Thomas from 'Feedback for Daniel Thomas' and rename my PDF file as it is. I have a total of 180 files; a sample the code I got from online, please help.
Sub RenamePDF()
Dim sh As Shape
Dim sDirectory As String
Dim sFile As String
Dim sText As String
Dim lSetting As Long
Dim i As Integer
Application.DisplayAlerts = wdAlertsNone
lSetting = Options.ConfirmConversions
Options.ConfirmConversions = False
sDirectory = "C:\Users\user123\Desktop\"
sFile = Dir(sDirectory & "\" & "*.pdf")
Do While sFile <> ""
Documents.Open FileName:=sDirectory & "\" & sFile
For Each sh In ActiveDocument.Shapes
If sh.Type = 6 Then '6 is a grouped shape
For i = 1 To sh.GroupItems.Count
If sh.GroupItems(i).Type = 1 Then '1 is a rectangle
sText = sh.GroupItems(4).TextFrame.TextRange.Text 'explicitly get 4th rectangle
Exit For
End If
Next i
End If
Next sh
sText = Left(sText, Len(sText) - 1)
ActiveDocument.Close False
Name sDirectory & sFile As sDirectory & Split(sFile, "-")(0) & " - " & sText & ".pdf"
sFile = Dir
Loop
Options.ConfirmConversions = lSetting
Application.DisplayAlerts = wdAlertsAll
End Sub
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
I'm working in a macro that convert CSV to Excel (xlsx). The problem is that, althought the extension change, the new converted file to excel keeps the structure of a CSV file, I mean, not separated by columns.
myFile = Dir(myPath & "*.csv")
Set wb = Workbooks.Open(myPath & myFile)
wb.SaveAs myPath & Replace(myFile, ".csv", ""), xlOpenXMLWorkbook
wb.Close False
Is there something wrong?
Thanks!
Your text file include some characters else of Ansi encoding.
And that need delete "=", quote. That's delimiter is semi-colon.
Line delimiter is ";;;" three semi-colon(my guess).
Sub openCsv()
Dim Wb As Workbook
Dim myPath As String, myFile As String
Dim newFile As String
Dim s As String
Dim vR(), vSplit, vSub
Dim n As Long, i As Long, j As Integer
myPath = ThisWorkbook.Path & "\" 'your path
myFile = "myTest.csv" 'your csv file
newFile = Split(myFile, ".")(0) & ".xlsx"
s = TransFromUtf_8(myPath & myFile)
s = Replace(s, "=", "")
s = Replace(s, Chr(34), "")
vSplit = Split(s, ";;;")
For i = 0 To UBound(vSplit)
n = n + 1
vSub = Split(vSplit(i), ";")
ReDim Preserve vR(1 To 30, 1 To n)
For j = 0 To UBound(vSub)
vR(j + 1, n) = vSub(j)
Next j
Next i
Set Wb = Workbooks.Add
With Wb
With .Sheets(1)
.Cells.NumberFormatLocal = "#"
.Range("a1").Resize(n, 30) = WorksheetFunction.Transpose(vR)
.Columns.AutoFit
End With
.SaveAs myPath & newFile
.Close (0)
End With
End Sub
Function TransFromUtf_8(myFile As String)
Dim objStream
Set objStream = CreateObject("ADODB.Stream")
With objStream
.Charset = "utf-8"
.Open
.LoadFromFile myFile
TransFromUtf_8 = .ReadText
.Close
End With
Set objStream = Nothing
End Function
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
I am trying to upload a few hundred folders each with files inside of them into SharePoint, but unfortunately SharePoint doesn't allow any special characters like "%".
I'm trying to use a VBA code that can automatically go into each subfolder and replace any special characters contained within the files such as "%", "#", etc.
So far what I have is:
Sub ChangeFileName()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set Folder = objFSO.GetFolder("C:\Users\Documents\TEST\Subfolder")
'Currently the way I have it requires me to change my path a few hundred times
For Each File In Folder.Files
sNewFile = File.Name
sNewFile = Replace(sNewFile, "%", "_")
sNewFile = Replace(sNewFile, "#", "_")
'^and so on`
If (sNewFile <> File.Name) Then
File.Move (File.ParentFolder + "\" + sNewFile)
End If
Next
End Sub
However for the script above, you need the specific sub-folder path. Wondering if there's any way to automatically replace the special characters of files within subfolders. I can also paste all the specific subfolder paths into column A of my Excel worksheet if that helps.
Thank you!
I use this code
Sub GetFileFromFolder()
Dim fd As FileDialog
Dim strFolder As String
Dim colResult As Collection
Dim i As Long, k As Long
Dim vSplit
Dim strFn As String
Dim vR() As String
Dim p As String
Dim iLevel As Integer, cnt As Long
'iLevel = InputBox(" Subfolder step : ex) 2 ")
p = Application.PathSeparator
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Show
.InitialView = msoFileDialogViewList
.Title = "Select your Root folder"
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
Else
strFolder = .SelectedItems(1)
Set colResult = SearchFolder(strFolder)
i = colResult.Count
For k = 1 To i
vSplit = Split(colResult(k), p)
strFn = vSplit(UBound(vSplit))
strFn = Replace(strFn, "%", "_")
strFn = Replace(strFn, "#", "_")
'If UBound(vSplit) - UBound(Split(strFolder, p)) = iLevel Then
cnt = cnt + 1
ReDim Preserve vR(1 To 3, 1 To cnt)
On Error Resume Next
Err.Clear
Name colResult(k) As strFolder & strFn
vR(1, cnt) = colResult(k)
If Err.Number = 58 Then
strFn = Split(strFn, ".")(0) & "_" & vSplit(UBound(vSplit) - 1) & "_" & Date & "." & Split(strFn, ".")(1)
Name colResult(k) As strFolder & strFn
vR(2, cnt) = strFolder & strFn
vR(3, cnt) = "Changed name " 'When filename is duplicated chage filename
Else
vR(2, cnt) = strFolder & strFn
End If
' End If
Next k
ActiveSheet.UsedRange.Offset(1).Clear
Range("a3").Resize(1, 3) = Array("Old file", "New file", "Ect")
If cnt > 0 Then
Range("a4").Resize(cnt, 3) = WorksheetFunction.Transpose(vR)
End If
With ActiveSheet.UsedRange
.Borders.LineStyle = xlContinuous
.Columns.AutoFit
.Font.Size = 9
End With
End If
End With
MsgBox cnt & " files moved!! "
End Sub
Function SearchFolder(strRoot As String)
Dim FS As Object
Dim fsFD As Object
Dim f As Object
Dim colFile As Collection
Dim p As String
On Error Resume Next
p = Application.PathSeparator
If Right(strRoot, 1) = p Then
Else
strRoot = strRoot & p
End If
Set FS = CreateObject("Scripting.FileSystemObject")
Set fsFD = FS.GetFolder(strRoot)
Set colFile = New Collection
For Each f In fsFD.Files
colFile.Add f.Path
Next f
SearchSubfolder colFile, fsFD
Set SearchFolder = colFile
Set fsFD = Nothing
Set FS = Nothing
Set colFile = Nothing
End Function
Sub SearchSubfolder(colFile As Collection, objFolder As Object)
Dim sbFolder As Object
Dim f As Object
For Each sbFolder In objFolder.subfolders
SearchSubfolder colFile, sbFolder
For Each f In sbFolder.Files
colFile.Add f.Path
Next f
Next sbFolder
End Sub