While running the script for more files, if it found the same name then it adds an incrementing number for the duplicate name at the end, but then it adds the increment number even for some unique name also, not for all unique name.
What goes wrong here?
Here is the image for your ref. In the image, I have hidden some parts of the file name for privacy.
File Name
Option Explicit
Sub RenameAllFilesInFolder()
Dim MyFolder As String
Dim MyFile As String, fName As String
Dim MyFilePatNm As String
Dim owbk As Workbook, ws As Worksheet
Dim v As String, fv As String, chkFile As String
Dim strFileName As String
Dim strFileExists As String
Dim fnum As Integer
MyFolder = "E:\SC_SS\"
MyFile = Dir(MyFolder & "*size*.xls")
Do Until MyFile = ""
MyFilePatNm = MyFolder & MyFile
Set owbk = Workbooks.Open(MyFilePatNm)
Set ws = owbk.Sheets(1)
v = "SS_" & ws.[C3].Value
chkFile = v & ".xls"
strFileName = MyFolder & chkFile
strFileExists = Dir(strFileName)
Do While strFileExists <> ""
fnum = fnum + 1
strFileExists = Dir(MyFolder & v & " " & fnum & ".xls")
Loop
If fnum > 0 Then
fv = v & " " & fnum & ".xls"
Else
fv = v & ".xls"
End If
fName = MyFolder & fv
ws.SaveAs Filename:=fName, FileFormat:=xlExcel8, CreateBackup:=False
Windows(fv).Close False
Kill MyFilePatNm
MyFile = Dir(MyFolder & "*size*.xls")
Loop
End Sub
I got the job done, with setting fnum to zero in below.
If fnum > 0 Then
fv = v & " " & fnum & ".xls"
Else
fv = v & ".xls"
End If
fnum = 0
Related
I have a code which can transfer the Excel files from one folder to another but i would like to update the code so that it can move all the files (.xml, .txt, .pdf, etc.) from one folder to another.
Sub MoveFiles()
Dim sourceFolderPath As String, destinationFolderPath As String
Dim FSO As Object, sourceFolder As Object, file As Object
Dim fileName As String, sourceFilePath As String, destinationFilePath As String
Application.ScreenUpdating = False
sourceFolderPath = "E:\Source"
destinationFolderPath = "E:\Destination"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set sourceFolder = FSO.GetFolder(sourceFolderPath)
For Each file In sourceFolder.Files
fileName = file.Name
If InStr(fileName, ".xlsx") Then ' Only xlsx files will be moved
sourceFilePath = file.Path
destinationFilePath = destinationFolderPath & "\" & fileName
FSO.MoveFile Source:=sourceFilePath, Destination:=destinationFilePath
End If ' If InStr(sourceFileName, ".xlsx") Then' Only xlsx files will be moved
Next
'Don't need set file to nothing because it is initialized in for each loop
'and after this loop is automatically set to Nothing
Set sourceFolder = Nothing
Set FSO = Nothing
End Sub
can you please help
Move Files Using MoveFile
You would get greater control of things by using CopyFile and DeleteFile instead of MoveFile.
Using Dir, FileCopy, and Kill, instead of the FileSystemObject object and its methods, would make it simpler and also faster.
Option Explicit
Sub MoveFilesTEST()
Const sFolderPath As String = "E:\Source"
Const dFolderPath As String = "E:\Destination"
Const FilePattern As String = "*.*"
MoveFiles sFolderPath, dFolderPath, FilePattern
End Sub
Sub MoveFiles( _
ByVal SourceFolderPath As String, _
ByVal DestinationFolderPath As String, _
Optional ByVal FilePattern As String = "*.*")
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(SourceFolderPath) Then
MsgBox "The source folder path '" & SourceFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
If Not fso.FolderExists(DestinationFolderPath) Then
MsgBox "The destination folder path '" & DestinationFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
Dim apSep As String: apSep = Application.PathSeparator
Dim sPath As String: sPath = SourceFolderPath
If Left(sPath, 1) <> apSep Then sPath = sPath & apSep
Dim sFolder As Object: Set sFolder = fso.GetFolder(sPath)
If sFolder.Files.Count = 0 Then
MsgBox "There are no files in the source folder '" & sPath & "'.", _
vbExclamation
Exit Sub
End If
Dim dPath As String: dPath = DestinationFolderPath
If Left(dPath, 1) <> apSep Then dPath = dPath & apSep
Dim dFolder As Object: Set dFolder = fso.GetFolder(dPath)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim sFile As Object
Dim dFilePath As String
Dim ErrNum As Long
Dim MovedCount As Long
Dim NotMovedCount As Long
For Each sFile In sFolder.Files
dFilePath = dPath & sFile.Name
If fso.FileExists(dFilePath) Then
dict(sFile.Path) = Empty
NotMovedCount = NotMovedCount + 1
Else
On Error Resume Next
fso.MoveFile sFile.Path, dFilePath
ErrNum = Err.Number
' e.g. 'Run-time error '70': Permission denied' e.g.
' when the file is open in Excel
On Error GoTo 0
If ErrNum = 0 Then
MovedCount = MovedCount + 1
Else
dict(sFile.Path) = Empty
NotMovedCount = NotMovedCount + 1
End If
End If
Next sFile
Dim Msg As String
Msg = "Files moved: " & MovedCount & "(" & NotMovedCount + MovedCount & ")"
If NotMovedCount > 0 Then
Msg = Msg & vbLf & "Files not moved:" & NotMovedCount & "(" _
& NotMovedCount + MovedCount & ")" & vbLf & vbLf _
& "The following files were not moved:" & vbLf _
& Join(dict.keys, vbLf)
End If
MsgBox Msg, IIf(NotMovedCount = 0, vbInformation, vbCritical)
End Sub
I am trying to rename my folder files. However, every time I try to run the below script, I see an error:
can’t find project or library on Sub and set FSO
How can I fix it?
Sub renameFiles()
'
' renamefiles Macro
'
Dim folderpath As String
Dim file_name As String
Dim target_folder As String
Dim trim_file_name As String
Set fso = CreateObject("Scripting.FileSystemObject")
folderpath = ThisWorkbook.Sheets("File Converter").Range("C7").Value & "\"
newFileName = Range("").Value
fileCount = 0
filePath = Dir$(folderpath & "*.*")
Do While filePath <> ""
fileCount = fileCount + 1
fileNames = fileNames & filePath & "," & newFileName & CStr(fileCount) & "." &
fso.GetExtensionName(filePath) & ","
filePath = Dir$
Loop
Dim renameFiles() As String
renameFiles = Split(fileNames, ",")
For fileCount = 0 To UBound(renameFiles) - 2 Step 2
Name folderpath & renameFiles(fileCount) As folderpath & renameFiles(fileCount + 1)
Next
End Sub
I am trying to automatically save my active workbook into another folder on my computer and if there is already a file with the name of my workbook in that folder, then it should be saved with "_v1"/"_v2" and so on at the end of its name.
I have found this code but it works just for the current folder, where the workbook is saved.
Sub SaveNewVersion_Excel()
Dim FolderPath As String
Dim myPath As String
Dim SaveName As String
Dim SaveExt As String
Dim VersionExt As String
Dim Saved As Boolean
Dim x As Long
TestStr = ""
Saved = False
x = 2
VersionExt = "_v"
On Error GoTo NotSavedYet
myPath = "O:\Operations\Department\Data Bank Coordinator\_PROJECTS_\QC BeadRegion Check\Multi Ref Archiv"
myFileName = Mid(myPath, InStrRev(myPath, "\") + 1, InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)
FolderPath = Left(myPath, InStrRev(myPath, "\"))
SaveExt = "." & Right(myPath, Len(myPath) - InStrRev(myPath, "."))
On Error GoTo 0
If InStr(1, myFileName, VersionExt) > 1 Then
myArray = Split(myFileName, VersionExt)
SaveName = myArray(0)
Else
SaveName = myFileName
End If
If FileExist(FolderPath & SaveName & SaveExt) = False Then
ActiveWorkbook.saveAs FolderPath & SaveName & SaveExt
Exit Sub
End If
Do While Saved = False
If FileExist(FolderPath & SaveName & VersionExt & x & SaveExt) = False Then
ActiveWorkbook.saveAs FolderPath & SaveName & VersionExt & x & SaveExt
Saved = True
Else
x = x + 1
End If
Loop
Exit Sub
NotSavedYet:
MsgBox "This file has not been initially saved. " & _
"Cannot save a new version!", vbCritical, "Not Saved To Computer"
End Sub
Function FileExist(FilePath As String) As Boolean
Dim TestStr As String
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
If TestStr = "" Then
FileExist = False
Else
FileExist = True
End If
End Function
It works for the current folder but when I change the folder path it doesn't work.
I would very much appreciate it if you could help me.
Thanks!
Sergiu
I've assumed the new folder is "D:_PROJECTS_\Multi Ref Archiv" and that if the existing file is zzzz_v07.xlsm then you want this saved as zzzz_v08.xlsm even when there are no previous versions in the folder. I added the leading zero so they sort nicely!
Sub SaveNewVersion_Excel2()
Const FOLDER = "D:\_PROJECTS_\Multi Ref Archiv" ' new location
Const MAX_FILES = 99
Dim oFSO As Object, oFolder As Object, bOK As Boolean, res As Variant
Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim sFilename As String, sFilename_v As String
' filename only
sFilename = ThisWorkbook.Name
' check folder exists
If Not oFSO.folderexists(FOLDER) Then
bOK = MsgBox(FOLDER & " does not exist. Do you want to create ?", vbYesNo, "Confirm")
If bOK Then
oFSO.createFolder FOLDER
MsgBox "OK created " & FOLDER, vbInformation
Else
Exit Sub
End If
End If
' get next name
sFilename_v = Next_v(sFilename)
' check if exists
Dim i As Integer: i = 1
Do While oFSO.fileexists(FOLDER & "\" & sFilename_v) = True And i <= MAX_FILES
i = i + 1
sFilename_v = Next_v(sFilename_v)
Loop
' check loop ok
If i > MAX_FILES Then
MsgBox "More than " & MAX_FILES & " files already exist", vbExclamation
Exit Sub
End If
sFilename_v = FOLDER & "\" & sFilename_v
' confirm save
res = MsgBox("Do you want to save to " & sFilename_v, vbYesNo, "Confirm")
If res = vbYes Then
ActiveWorkbook.SaveAs sFilename_v
MsgBox "Done", vbInformation
End If
End Sub
Function Next_v(s As String)
Const ver = "_v"
Dim i As Integer, j As Integer, ext As String, rev As Integer
i = InStrRev(s, ".")
j = InStrRev(s, ver)
ext = Mid(s, i)
' increment existing _v if exists
If j > 0 Then
rev = Mid(s, j + 2, i - j - 2)
s = Left(s, j - 1)
Else
rev = 0
s = Left(s, i - 1)
End If
Next_v = s & ver & Format(rev + 1, "00") & ext
End Function
You can move all of the logic out to a separate function, then you only need to call that to get the "correct" name to save as.
'Pass in the full path and filename
' Append "_Vx" while the passed filename is found in the folder
' Returns empty string if the path is not valid
Function NextFileName(fPath As String)
Const V As String = "_V"
Dim fso, i, p, base, ext
Set fso = CreateObject("scripting.filesystemobject")
'valid parent folder?
If fso.folderexists(fso.GetParentFolderName(fPath)) Then
p = fPath
ext = fso.getextensionname(p)
base = Left(p, Len(p) - (1 + Len(ext))) 'base name without extension
i = 1
Do While fso.fileexists(p)
i = i + 1
p = base & (V & i) & "." & ext
Loop
End If
NextFileName = p
End Function
I need to rename 300+ files of various extensions in 1 folder. I have a list of file names without extension in column B, and final names in column A of my Excel worksheet. My code works, but renames files in wrong order. Filenames contain dots, like
А1.14.12.2016
Here is the code:
Option Explicit
Sub test2()
Dim x As String
Dim fName As String
Dim oldPath As String
Dim newPath As String
Dim i As Long
oldPath = "\\Plu20\dfs01\USMiKAR\docs\"
newPath = oldPath & "New\"
On Error Resume Next
x = GetAttr(newPath) And 0
If Err.Number <> 0 Then MkDir newPath
fName = Dir(oldPath & "*.*")
With ActiveSheet
Do While Len(fName) > 0
i = i + 1
FileCopy oldPath & fName, newPath & .Cells(i, 1) & Mid$(fName, InStrRev(fName, "."))
'.Cells(i, 2) = oldPath & fName 'ïðîâåðêà
'Kill oldPath & fName 'óäàëåíèå ñòàðûõ
fName = Dir
Loop
End With
End Sub
Untested, but you can do something like this:
Sub test2()
Dim x As String
Dim fName As String
Dim oldPath As String
Dim newPath As String
Dim i As Long
Dim fso As Object, f As Range
Set fso = CreateObject("scripting.filesystemobject")
oldPath = "\\Plu20\dfs01\USMiKAR\docs\"
newPath = oldPath & "New\"
If Dir(newPath, vbDirectory) = "" Then MkDir newPath
fName = Dir(oldPath & "*.*")
With ActiveSheet
Do While Len(fName) > 0
'find the current filename
Set f = .Columns(2).Find(fso.getbasename(fName), lookat:=xlWhole)
If Not f Is Nothing Then
'got a match
FileCopy oldPath & fName, _
newPath & f.Offset(0, -1).Value & "." & fso.getextensionname(fName)
'.Cells(i, 2) = oldPath & fName 'ïðîâåðêà
'Kill oldPath & fName 'óäàëåíèå ñòàðûõ
Else
'no match...
Debug.Print "filename:" & fName & " was not matched"
End If
fName = Dir
Loop
End With
End Sub
My code copy the open workbook and then renames the copied one with the month of analysis, but I need to save all the analysis of the month doing a sequence at the end of the file name. I tried some simple loops and it doesn't work.
Sub NewReport()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim dateStr As String
Dim myDate As Date
Dim i As Integer
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
Set Wb1 = ActiveWorkbook
myDate = Date
dateStr = Format(myDate, "mmm_yyyy")
Set Wb2 = Application.Workbooks.Add(1)
Wb1.Sheets(Array(Wb1.Sheets(1).Name)).Copy Before:=Wb2.Sheets(1)
Wb2.Sheets(Wb2.Sheets.Count).Delete
On Error GoTo Fim
'Wb2.SaveAs Filename:="\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\" & "Phase_IN_Phase_OUT" & "_" & dateStr, FileFormat:=51
'Wb2.Close
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
Fim:
Wb2.SaveAs Filename:="\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\" & "Phase_IN_Phase_OUT" & "_" & dateStr & "_", FileFormat:=51
End Sub
UPDATE
I tried put an "i + 1" and the macro runs until version 2! But at the 3rd I have the same error because the "i" is reseted. I can do the bit at the end for like 50 times assuming that the person don't run the macro 50 times haha. Any suggestions?
Sub NewReport()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim dateStr As String
Dim myDate As Date
i = 1
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
Set Wb1 = ActiveWorkbook
myDate = Date
dateStr = Format(myDate, "mmm_yyyy")
Set Wb2 = Application.Workbooks.Add(1)
Wb1.Sheets(Array(Wb1.Sheets(1).Name)).Copy Before:=Wb2.Sheets(1)
Wb2.Sheets(Wb2.Sheets.Count).Delete
On Error GoTo Fim
Wb2.SaveAs Filename:="\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\" & "Phase_IN_Phase_OUT" & "_" & dateStr & "_" & i, FileFormat:=51
'Wb2.Close
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
Fim:
i = i + 1
Wb2.SaveAs Filename:="\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\" & "Phase_IN_Phase_OUT" & "_" & dateStr & "_" & i, FileFormat:=51
End Sub
So, the question is how to get from something like:
\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT_probablySomeString_21
an incremented value at the end like this one:
\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT_probablySomeString_22
This could be carried out through the following steps:
Take the string and split it by _.
Increment the last part of the string with 1.
Public Sub TestMe()
Dim fileName As String
Dim dateStr As String: dateStr = "probablySomeString"
Dim i As Long: i = 21
fileName = "\\BRGABS001\g_supc\P.C.P\07- Comum\" & _
"Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT" & "_" & dateStr & "_" & i
Debug.Print fileName
Debug.Print Increment(fileName)
End Sub
Public Function Increment(fileName As String) As String
Dim myResult As String
Dim newValue As Long
Dim myArr As Variant
newValue = Split(fileName, "_")(UBound(Split(fileName, "_"))) + 1
myArr = Split(fileName, "_")
myArr(UBound(Split(fileName, "_"))) = newValue
Increment = Join(myArr, "_")
End Function
And if the initial file looks like this:
~omum\Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT_probablySomeString_21.xlsx then
the following sample works:
Public Sub TestMe()
Dim fileName As String
Dim dateStr As String: dateStr = "probablySomeString"
Dim i As Long: i = 21
fileName = "\\BRGABS001\g_supc\P.C.P\07- Comum\" & _
"Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT" & "_" & dateStr & "_" & i & ".xlsx"
Debug.Print fileName
Debug.Print Increment(fileName)
End Sub
Public Function Increment(fileName As String) As String
Dim myResult As String
Dim newValue As Long
Dim myArr As Variant
newValue = Split(Split(fileName, "_")(UBound(Split(fileName, "_"))), ".")(0) + 1
myArr = Split(fileName, "_")
myArr(UBound(Split(fileName, "_"))) = newValue
Increment = Join(myArr, "_")
Increment = Increment & ".xslx"
End Function
After a deep research on google, I found a code and adapt to my situation. It doesn't let to choose the way to save, it's just in the same Folder, but that's ok to me. Credits on the code (I have just put the date at the name):
Function FileExist(FilePath As String) As Boolean
'PURPOSE: Test to see if a file exists or not
'SOURCE: www.TheSpreadsheetGuru.com/The-Code-Vault
'RESOURCE: http://www.rondebruin.nl/win/s9/win003.htm
Dim TestStr As String
'Test File Path (ie "C:\Users\Chris\Desktop\Test\book1.xlsm")
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
'Determine if File exists
If TestStr = "" Then
FileExist = False
Else
FileExist = True
End If
End Function
Sub SaveNewVersion_Excel()
'PURPOSE: Save file, if already exists add a new version indicator to filename
'SOURCE: www.TheSpreadsheetGuru.com/The-Code-Vault
Dim FolderPath As String
Dim myPath As String
Dim SaveName As String
Dim SaveExt As String
Dim VersionExt As String
Dim Saved As Boolean
Dim x As Long
Dim dateStr As String
myDate = Date
dateStr = Format(myDate, "mmm_yyyy")
TestStr = ""
Saved = False
x = 2
'Version Indicator (change to liking)
VersionExt = "_" & dateStr & "_Rev"
'Pull info about file
On Error GoTo NotSavedYet
myPath = ActiveWorkbook.FullName
myFileName = Mid(myPath, InStrRev(myPath, "\") + 1, InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)
FolderPath = Left(myPath, InStrRev(myPath, "\"))
SaveExt = "." & Right(myPath, Len(myPath) - InStrRev(myPath, "."))
On Error GoTo 0
'Determine Base File Name
If InStr(1, myFileName, VersionExt) > 1 Then
myArray = Split(myFileName, VersionExt)
SaveName = myArray(0)
Else
SaveName = myFileName
End If
'Test to see if file name already exists
If FileExist(FolderPath & SaveName & SaveExt) = False Then
ActiveWorkbook.SaveAs FolderPath & SaveName & SaveExt
Exit Sub
End If
'Need a new version made
Do While Saved = False
If FileExist(FolderPath & SaveName & VersionExt & x & SaveExt) = False Then
ActiveWorkbook.SaveAs FolderPath & SaveName & VersionExt & x & SaveExt
Saved = True
Else
x = x + 1
End If
Loop
'New version saved
MsgBox "New file version saved (version " & x & ")"
Exit Sub
'Error Handler
NotSavedYet:
MsgBox "This file has not been initially saved. " & _
"Cannot save a new version!", vbCritical, "Not Saved To Computer"
End Sub