I want to replace anything before an underscore and prefix underscore with an increasing integer i in excel vba to rename all the files in a folder.
Sub RenameFiles()
Const FolderLoc = "P:\yourfolder\"
Dim x As Long
x = 1
Dim s As String
s = Dir(FolderLoc & "*.*")
Do While s <> ""
Name FolderLoc & s As FolderLoc & x & Right(s, Len(s) - (InStr(s, "_") - 1))
s = Dir()
x = x + 1
Loop
End Sub
'MACRO to Rename backed up files and place in order
Sub Rename2()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object, abc As Object
Dim i As String
Dim s As String, dest As String
dest = "H:\Automation\outputs\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
FolderLoc = dest
Set objFolder = objFSO.GetFolder(dest)
'MsgBox objFolder
i = 1
s = Dir(FolderLoc & "*.*")
On Error Resume Next
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
Do While (InStr(s, "_")) > 0
'MsgBox s
'Name OldFile as NewFile
Name FolderLoc & s As FolderLoc & i & "." & Right(s, Len(s) - (InStr(s, "_") + 2))
s = i & "." & Right(s, Len(s) - (InStr(s, "_") + 2))
'MsgBox s
'abc = Name FolderLoc & s As FolderLoc & "(" & i & ")" & Right(s, Len(s) - (InStr(s, "#_#") + 2))
'i = i + 1
Loop
i = i + 1
s = Dir()
Next objFile
End Sub
Related
Can anyone please help me update the below VBA Code which I found in the below website, I changed the MyPath to loop through the rows but somehow it only merged the first folder in loop and it is not merging the next folder in the given rows.
http://www.vbaexpress.com/forum/showthread.php?47310-Need-code-to-merge-PDF-files-in-a-folder-using-adobe-acrobat-X/page3
Option Explicit
Sub Main()
Dim DestFile As String ' <-- change to suit
Dim MyPath As String, MyFiles As String
Dim a() As String, i, j, numRows As Long, f As String
' Choose the folder or just replace that part by: MyPath = Range("E3")
'With Application.FileDialog(msoFileDialogFolderPicker)
'.InitialFileName = "C:\Temp\"
'.AllowMultiSelect = False
' If .Show = False Then Exit Sub
'MyPath = .SelectedItems(1)
' DoEvents
'End With
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set ws = wb.Worksheets("ForProcessing")
numRows = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
For j = 5 To numRows
MyPath = ws.Cells(j, 1).Value
DestFile = ws.Cells(j, 2).Value & " Rev " & ws.Cells(j, 6).Value & ".pdf"
' Populate the array a() by PDF file names
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
ReDim a(1 To 2 ^ 14)
f = Dir(MyPath & "*.pdf")
While Len(f)
If StrComp(f, DestFile, vbTextCompare) Then
i = i + 1
a(i) = f
End If
f = Dir()
Wend
' Merge PDFs
If i Then
ReDim Preserve a(1 To i)
MyFiles = Join(a, ",")
Application.StatusBar = "Merging, please wait ..."
Call MergePDFs(MyPath, MyFiles, DestFile)
Application.StatusBar = False
Else
MsgBox "No PDF files found in" & vbLf & MyPath, vbExclamation, "Canceled"
End If
Next j
End Sub
Sub MergePDFs(MyPath As String, MyFiles As String, Optional DestFile As String = "MergedFile.pdf")
' ZVI:2013-08-27 http://www.vbaexpress.com/forum/showthread.php?47310-Need-code-to-merge-PDF-files-in-a-folder-using-adobe-acrobat-X
' Reference required: VBE - Tools - References - Acrobat
Dim a As Variant, i As Long, n As Long, ni As Long, p As String
Dim AcroApp As New Acrobat.AcroApp, PartDocs() As Acrobat.CAcroPDDoc
If Right(MyPath, 1) = "\" Then p = MyPath Else p = MyPath & "\"
a = Split(MyFiles, ",")
ReDim PartDocs(0 To UBound(a))
On Error GoTo exit_
If Len(Dir(p & DestFile)) Then Kill p & DestFile
For i = 0 To UBound(a)
' Check PDF file presence
If Dir(p & Trim(a(i))) = "" Then
MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "Canceled"
Exit For
End If
' Open PDF document
Set PartDocs(i) = CreateObject("AcroExch.PDDoc")
PartDocs(i).Open p & Trim(a(i))
If i Then
' Merge PDF to PartDocs(0) document
ni = PartDocs(i).GetNumPages()
If Not PartDocs(0).InsertPages(n - 1, PartDocs(i), 0, ni, True) Then
MsgBox "Cannot insert pages of" & vbLf & p & a(i), vbExclamation, "Canceled"
End If
' Calc the number of pages in the merged document
n = n + ni
' Release the memory
PartDocs(i).Close
Set PartDocs(i) = Nothing
Else
' Calc the number of pages in PartDocs(0) document
n = PartDocs(0).GetNumPages()
End If
Next
If i > UBound(a) Then
' Save the merged document to DestFile
If Not PartDocs(0).Save(PDSaveFull, p & DestFile) Then
MsgBox "Cannot save the resulting document" & vbLf & p & DestFile, vbExclamation, "Canceled"
End If
End If
exit_:
' Inform about error/success
If Err Then
MsgBox Err.Description, vbCritical, "Error #" & Err.Number
ElseIf i > UBound(a) Then
MsgBox "The resulting file is created:" & vbLf & p & DestFile, vbInformation, "Done"
End If
' Release the memory
If Not PartDocs(0) Is Nothing Then PartDocs(0).Close
Set PartDocs(0) = Nothing
' Quit Acrobat application
AcroApp.Exit
Set AcroApp = Nothing
End Sub
I'm getting the first pdf combined as per the code, however, when it reads the next row this code
MyFiles = Join(a, ",")
The MyFiles value is having two comma before the set of PDF files that needed to be merged like this >>> ",,name1.pdf,name2.pdf"
If anyone can help me update this code will very much appreciated.
Thanks,
Mielkew
There is folder A which contains multiple subfolders like A1,A2, A3 etc which every subfolder has mostly one sometimes 2 word files with the name(eg file_a1) in it. Then, there is other folder B (not a subfolder of A) which contains multiple word files with standard similar (file_a1_XZ) names.
I want to loop in subfolders of A and copy word files from B to respective sub folder e.g A1
File Structure:
Parent Folder
|
|
----Parent B
|
|
--- B
|
-file_a1_XZ
-file_a2_XZ
----Parent A
|
|
--- A
|
|
-- A1
|
-file_a1
-- A2
|
-file_a2
Move Files to Specific Folders Using Dir
Moves files from B to subfolders of A i.e. the filenames contain the names of the subfolders.
Option Explicit
Sub MoveFiles()
Const sFolderPath As String = "C:\Test\T2022\71752347\B\"
Const dFolderPath As String = "C:\Test\T2022\71752347\A\"
Const sExtensionPattern As String = ".doc*"
Dim dFolderName As String: dFolderName = Dir(dFolderPath, vbDirectory)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Do Until Len(dFolderName) = 0
If dFolderName <> "." And dFolderName <> ".." Then
dict(dFolderName) = Empty
End If
dFolderName = Dir
Loop
Dim Key As Variant
Dim sFileName As String
Dim fCount As Long
For Each Key In dict.Keys
sFileName = Dir(sFolderPath & "*" & Key & "*" & sExtensionPattern)
Do Until Len(sFileName) = 0
fCount = fCount + 1
FileCopy sFolderPath & sFileName, _
dFolderPath & Key & "\" & sFileName
Kill sFolderPath & sFileName
sFileName = Dir
Loop
Next
MsgBox "Files moved: " & fCount, vbInformation
End Sub
If the files in B are in various subfolders, use the following.
Sub MoveFiles()
Const sFolderPath As String = "C:\Test\T2022\71752347\B\"
Const dFolderPath As String = "C:\Test\T2022\71752347\A\"
Const sExtensionPattern As String = ".doc*"
Dim dFolderName As String: dFolderName = Dir(dFolderPath, vbDirectory)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Do Until Len(dFolderName) = 0
If dFolderName <> "." And dFolderName <> ".." Then
dict(dFolderName) = Empty
End If
dFolderName = Dir
Loop
Dim sFilePaths() As String
Dim sFilePath As String
Dim dFilePath As String
Dim Key As Variant
Dim f As Long
Dim fCount As Long
For Each Key In dict.Keys
sFilePaths = ArrFilePaths(sFolderPath, _
"*" & Key & "*" & sExtensionPattern)
For f = 0 To UBound(sFilePaths)
fCount = fCount + 1
sFilePath = sFilePaths(f)
dFilePath = dFolderPath & Key & "\" & Right(sFilePath, _
Len(sFilePath) - InStrRev(sFilePath, "\"))
FileCopy sFilePath, dFilePath
Kill sFilePath
Next f
Next Key
MsgBox "Files moved: " & fCount, vbInformation
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the file paths of the files in a folder
' in a zero-based string array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrFilePaths( _
ByVal FolderPath As String, _
Optional ByVal FilePattern As String = "*.*", _
Optional ByVal DirSwitches As String = "/s/b/a-d") _
As String()
Const ProcName As String = "ArrFilePaths"
On Error GoTo ClearError
' Ensuring that a string array is passed if an error occurs.
ArrFilePaths = Split("") ' LB = 0 , UB = -1
Dim pSep As String: pSep = Application.PathSeparator
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
Dim ExecString As String ' '%comspec%' or 'cmd.exe' ?
ExecString = "%comspec% /c Dir """ _
& FolderPath & FilePattern & """ " & DirSwitches
Dim Arr() As String: Arr = Split(CreateObject("WScript.Shell") _
.Exec(ExecString).StdOut.ReadAll, vbCrLf)
If UBound(Arr) > 0 Then
ReDim Preserve Arr(0 To UBound(Arr) - 1)
End If
ArrFilePaths = Arr
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
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