How to rename multiple pdf files used excel database vba - vba

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

Related

Rename PDF based on its content

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

VBA; how to extract all files names from a folder - without using Application.FileDialog object

As in the Question: the task is to extract all files names from a folder, but the folder path needs to be hard coded into the macro, to prevent these dialog boxes asking me things and wasting my time.
I will not change this folder. It will be the same one until the end of time, and I want to extract the files names into the Excel column, starting from second row.
this is the folder I want to extract ALL files names from.
"C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\"
this is my portion of code:
Option Explicit
Sub GetFileNames()
Dim axRow As Long ' inside the Sheet("Lista") row#
Dim xDirectory As String
Dim xFname As String ' name of the file
Dim InitialFoldr$
Dim start As Double
Dim finish As Double
Dim total_time As Double
start = Timer
ThisWorkbook.Sheets("Lista").Range("D2").Activate
InitialFolder = "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst"
If Right(InitialFolder, 1) <> "\" Then
InitialFolder = InitialFolder & "\"
End If
Application.InitialFolder.Show
If InitialFolder.SelectedItems.Count <> 0 Then
xDirectory = .SelectedItems(1) & "\"
xFname = Dir(xDirectory, vbArchive)
' Dir's job is to return a string representing
' the name of a file, directory, or an archive that matches a specified pattern.
Do While xFname <> "" ' there is already xFname value (1st file name) assigned.
ActiveCell.Offset(xRow) = xFname
xRow = xRow + 1 ' następny xRow
xFname = Dir()
Loop
End If
End With
finish = Timer ' Set end time.
total_time = Round(finish - start, 3) ' Calculate total time.
MsgBox "This code ran successfully in " & total_time & " seconds", vbInformation
End Sub
this is the line that crushes:
If InitialFolder.SelectedItems.Count <> 0 Then
xDirectory = .SelectedItems(1) & "\"
And two more important questions in the .png file.
Please, respond to them as well - it's very important 4 me.
Or if U guys know any other method to do this faster just don't hesitate and share Your Code with me - I'll be very grateful.
Sub Files()
Dim sht As Worksheet
Dim strDirectory As String, strFile As String
Dim i As Integer: i = 1
Set sht = Worksheets("Sheet1")
strDirectory = "C:\Users\User\Desktop\"
strFile = Dir(strDirectory, vbNormal)
Do While strFile <> ""
With sht
.Cells(i, 1) = strFile
.Cells(i, 2) = strDirectory + strFile
End With
'returns the next file or directory in the path
strFile = Dir()
i = i + 1
Loop
End Sub
See example below
Public Sub Listpng()
Const strFolder As String = "C:\SomeFolder\"
Const strPattern As String = "*.png"
Dim strFile As String
strFile = Dir(strFolder & strPattern, vbNormal)
Do While Len(strFile) > 0
Debug.Print strFile '<- view this in Immediate window; Ctrl+g will take you there
strFile = Dir
Loop
End Sub
There's a couple of procedures I use depending on whether I want subfolders as well.
This loops through the folder and adds path & name to a collection:
Sub Test1()
Dim colFiles As Collection
Dim itm As Variant
Set colFiles = New Collection
EnumerateFiles "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\", "*.xls*", colFiles
For Each itm In colFiles
Debug.Print itm
Next itm
End Sub
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)
Dim sTemp As String
sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub
This second way goes through the subfolders as well returning path & name. For some reason if you change InclSubFolders to False it only returns the name - got to sort that bit out.
Sub Test2()
Dim vFiles As Variant
Dim itm As Variant
vFiles = EnumerateFiles_2("C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\", "xls*")
For Each itm In vFiles
Debug.Print itm
Next itm
End Sub
Public Function EnumerateFiles_2(sDirectory As String, _
Optional sFileSpec As String = "*", _
Optional InclSubFolders As Boolean = True) As Variant
EnumerateFiles_2 = Filter(Split(CreateObject("WScript.Shell").Exec _
("CMD /C DIR """ & sDirectory & "*." & sFileSpec & """ " & _
IIf(InclSubFolders, "/S ", "") & "/B /A:-D").StdOut.ReadAll, vbCrLf), ".")
End Function

Change File Names within Subfolders with VBA

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

VBA Excel execute macro in all subfolders, not only particular folders

I am having problems with my code since it only works in the specific folders but not in all subfolders inside the particular folder.
Could someone please helps to make the code works to all subfolders inside that specific folder? :)
These are my code:
Sub Execute1()
Dim monthstr As String
Dim year As String
Dim monthtext As String
Dim prevmonth As String
Dim prevmonthtext As String
year = Range("D8").Text
monthstr = Trim(Range("D9").Text)
monthtext = Trim(Range("D10").Text)
prevmonth = Trim(Range("D11").Text)
prevmonthtext = Trim(Range("D12").Text)
prevyear = Trim(Range("D13").Text)
'confirmation box before running macro//////////////////////////////////////////////////////////////////////////////////////
response = MsgBox("Are you sure the settings are correct?", vbYesNo, "Confirmation")
If response = vbNo Then
Exit Sub
End If
'optimize macro speed///////////////////////////////////////////////////////////////////////////////////////////////////////////
Call Optimize
'finding the correct path (month)//////////////////////////////////////////////////////////////////////////////////////////
Dim myfile As String
Dim mypath As String
Dim newpath As String
mypath = "C:\Users\praseirw\Desktop\Tes CC\" & prevyear & "\SC\" & prevmonth & " " & prevmonthtext & "\"
myfile = Dir(mypath & "*.xlsx")
newpath = "C:\Users\praseirw\Desktop\Tes CC\" & year & "\SC\" & monthstr & " " & monthtext & "\"
'loop through all files in specified month//////////////////////////////////////////////////////////////////////////////////
Dim root As Workbook
Dim rng As Range
Dim wb As Workbook
Dim ws As Worksheet
Set root = Workbooks("CC Reports Center.xlsm")
Set rng = root.Worksheets("Settings").Range("H7:H14")
Do While myfile <> ""
Set wb = Workbooks.Open(mypath & myfile)
For Each ws In wb.Worksheets
rng.Copy
With ws.Range("D1")
.PasteSpecial xlPasteFormulas
End With
Next ws
Dim oldname As String
Dim newname As String
Dim wbname As String
oldname = wb.Name
wbname = Mid(oldname, 9)
newname = year & "_" & monthstr & "_" & wbname
wb.SaveAs Filename:=newpath & newname
wb.Close
Set wb = Nothing
myfile = Dir
Loop
Application.CutCopyMode = False
MsgBox "Task Complete!"
'reset macro optimization settings//////////////////////////////////////////////////////////////////////////////////////////////
Call ResetOptimize
End Sub
Here's one way to do it with the Dir function. If you want something a little more elegant you may want to consider using a FileSystemObject. (Note that to view Debug.Print output you have to enable the immediate window from under view.)
Sub test()
Dim root As String
root = "C:\"
Dim DC As New Collection
s = Dir(root & "*", vbDirectory)
Do Until s = ""
DC.Add s
s = Dir
Loop
For Each D In DC
Debug.Print D
On Error Resume Next: s = Dir(root & D & "\*.xl*"): On Error GoTo 0
Do Until s = ""
Debug.Print " " & s
s = Dir
Loop
Next
End Sub
Here's an example of how to do this with a FileSystemObject. Note that my code is a little sloppy with "On error resume next" to protect against access denied or other errors. Realistically you may want to consider incorporating better error handling, but that's another topic. Using a FileSystemObject is more powerful than Dir because Dir only returns a string, while FileSystemObject lets you work with files and folders as actual objects, which are much more powerful.
Sub test()
'You can use "CreateObject..." to add a FileSystemObject from the Scipting Library
'Alternatively, you can add a reference to "Microsoft Scripting Runtime"
'allowing you to directly declare a filesystemobject and access related intellisense
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder = fso.GetFolder("C:\")
For Each SubFolder In Folder.SubFolders
Debug.Print SubFolder.Name
On Error Resume Next
For Each File In SubFolder.Files
Debug.Print " " & File.Name
Next
On Error GoTo 0
Next
End Sub

How can I return the file path of all files, within one folder? This is for Excel VBA

I have code that will allow me to return the file name of all files in a single folder. However, I would like to modify it to query a folder and return all the file paths of a particular file extension. (In this case .run files)
Any help would be appreciated! Thanks in advance.
Option Explicit
Sub GetFileNames()
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$
InitialFoldr$ = "G:\" '<<< Startup folder to begin searching from
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
Do While xFname$ <> ""
ActiveCell.Offset(xRow) = xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
End If
End With
End Sub
One more approach using Dir function:
Sub FilePaths()
Dim FileName As String
Dim FileMask As String
Dim InputFolder As String
Dim PathsArray() As String
Dim OutputRange As Range
InputFolder = "D:\DOCUMENTS\"
FileMask = "*.xls?"
Application.ScreenUpdating = False
FileName = Dir(InputFolder & FileMask)
ReDim PathsArray(0)
ThisWorkbook.ActiveSheet.Range("A1").CurrentRegion.ClearContents
Do While FileName <> ""
PathsArray(UBound(PathsArray)) = InputFolder & FileName
ReDim Preserve PathsArray(UBound(PathsArray) + 1)
FileName = Dir
Loop
ReDim Preserve PathsArray(UBound(PathsArray))
Set OutputRange = ThisWorkbook.Sheets(1).Range("A1:A" & (UBound(PathsArray)))
OutputRange = WorksheetFunction.Transpose(PathsArray)
ThisWorkbook.ActiveSheet.Range("A1").CurrentRegion.Columns.AutoFit
Application.ScreenUpdating = True
MsgBox UBound(PathsArray) & " file(s) listed from folder:" & vbNewLine & InputFolder
End Sub
Source path & file mask (wildcards *? are allowed) should be defined.
Sample file is available: https://www.dropbox.com/s/j55p8otdiw67i7q/FilePaths.xlsm