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
Related
Below mentioned code successfully copies the file based on source names mentioned in excel sheet using moveFilesFromListPartial, it works perfectly well. i just need one change in the code.
e.g. in excel sheet a source name is written as "Robert Anderson" However if a file with incorrect spelling like "Robert Andersonn" or "Robertt Anderson" comes into source folder, these file with incorrect spelling should get copy in another folder (e.g. Error Folder). In other words files whose exact source name is not in excel sheet should get copy to another folder rather than the destination folder. This way at the end of day we can identify which file names have spelling mistakes and we can simply correct them without reviewing all the files.
currently these kind of files remain stuck in source folder and because of incorrect file name they do not get copy, and i have added another macro which after some times moved the file from Source folder to Archive folder.
Sub moveFilesFromListPartial()
Const sPath As String = "E:\Uploading\Source"
Const dPath As String = "E:\Uploading\Destination"
Const fRow As Long = 2
Const Col As String = "B", colExt As String = "C"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = Sheet2
' Calculate the last row,
' i.e. the row containing the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
' Validate the last row.
If lRow < fRow Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
' Early Binding - needs a reference
' to 'Tools > References > Microsoft Scripting Runtime' (has intelli-sense)
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
' Late Binding - needs no reference (no intelli-sense)
'Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
' Validate the source folder path.
Dim sFolderPath As String: sFolderPath = sPath
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
If Not fso.FolderExists(sFolderPath) Then
MsgBox "The source folder path '" & sFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
' Validate the destination folder path.
Dim dFolderPath As String: dFolderPath = dPath
If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
If Not fso.FolderExists(dFolderPath) Then
MsgBox "The destination folder path '" & dFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
Dim r As Long ' current row in worksheet column
Dim sFilePath As String
Dim sPartialFileName As String
Dim sFileName As String
Dim dFilePath As String
Dim sYesCount As Long ' source file moved
Dim sNoCount As Long ' source file not found
Dim dYesCount As Long ' source file exists in destination folder
Dim BlanksCount As Long ' blank cell
Dim sExt As String 'extension (dot inclusive)
For r = fRow To lRow
sPartialFileName = CStr(ws.Cells(r, Col).Value)
sExt = CStr(ws.Cells(r, colExt).Value)
If Len(sPartialFileName) > 3 Then ' the cell is not blank
' 'Begins with' sPartialFileName
sFileName = Dir(sFolderPath & sPartialFileName & "*" & sExt)
Do While sFileName <> ""
If Len(sFileName) > 3 Then ' source file found
sFilePath = sFolderPath & sFileName
dFilePath = dFolderPath & sFileName
If Not fso.FileExists(dFilePath) Then ' the source file...
fso.CopyFile sFilePath, dFilePath ' ... doesn't exist...
sYesCount = sYesCount + 1 ' ... in the destination
Else ' the source file exists in the destination folder
dYesCount = dYesCount + 1
End If
Else ' the source file doesn't exist
sNoCount = sNoCount + 1
End If
sFileName = Dir
Loop
Else ' the cell is blank
BlanksCount = BlanksCount + 1
End If
Next r
End Sub
Another Code which I run after copying the file to Destination folder which moves the files from Source to Archive folder.
Sub moveAllFilesInDateFolderIfNotExist()
Dim DateFold As String, fileName As String, objFSO As Object
Const sFolderPath As String = "E:\Uploading\Source"
Const dFolderPath As String = "E:\Uploading\Archive"
DateFold = dFolderPath & "\" & Format(Date, "ddmmyyyy") ' create the folder
if it does not exist
If Dir(DateFold, vbDirectory) = "" Then MkDir DateFold
fileName = Dir(sFolderPath & "\*.*")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Do While fileName <> ""
If Not objFSO.FileExists(DateFold & "\" & fileName) Then
Name sFolderPath & "\" & fileName As DateFold & "\" & fileName
Else
Kill DateFold & "\" & fileName
Name sFolderPath & "\" & fileName As DateFold & "\" & fileName
End If
fileName = Dir
Loop
End Sub
Please, use the next updated (your macro):
Sub AddMissingItems()
Dim Dic As Object, arr() As Variant, outArr() As Variant
Dim i As Long, k As Long, iRow As Long, c As Long
Dim r As Long, j As Long
Set Dic = CreateObject("Scripting.dictionary")
With Sheets("Sheet1")
arr = .Range("A1:A" & .Range("A" & .rows.count).End(xlUp).row).Value
For i = 1 To UBound(arr, 1)
If Dic.Exists(arr(i, 1)) = False Then
Dic.Add (arr(i, 1)), ""
End If
Next
End With
With Workbooks("ExtractFile.xlsx").Worksheets("Sheet1")
c = .cells(1, Columns.count).End(xlToLeft).column
r = .Range("A" & .rows.count).End(xlUp).row 'calculate the last row in A:A, too
arr = .Range("A1", .cells(r, c)).Value 'place in the array all existing columns
ReDim outArr(1 To UBound(arr), 1 To c) 'extend the redimmed array to all columns
For i = 1 To UBound(arr)
If Dic.Exists(arr(i, 1)) = False Then
k = k + 1
For j = 1 To c 'iterate between all array columns:
outArr(k, j) = arr(i, j) 'place the value from each column
Next j
End If
Next
End With
iRow = Sheets("Sheet1").Range("A" & rows.count).End(3).row + 1
If k <> 0 Then
Sheets("Sheet1").Range("A" & iRow).Resize(k, UBound(arr, 2)).Value = outArr 'resize by columns, too
k = 0
End If
End Sub
Sub moveFilesFromListPartial()
Const sPath As String = "E:\Uploading\Source", dPath As String = "E:\Uploading\Destination"
Const Col As String = "B", colExt As String = "C"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = Sheet2
' Calculate the last row,
Dim lRow As Long: lRow = ws.cells(ws.rows.count, Col).End(xlUp).row
' Validate the last row.
If lRow < 2 Then MsgBox "No data in column range.", vbCritical: Exit Sub
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
' Validate the source folder path.
Dim sFolderPath As String: sFolderPath = sPath
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
If Not fso.FolderExists(sFolderPath) Then
MsgBox "The source folder path '" & sFolderPath & "' doesn't exist.", vbCritical: Exit Sub
End If
' Validate the destination folder path.
Dim dFolderPath As String: dFolderPath = dPath
If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
If Not fso.FolderExists(dFolderPath) Then
MsgBox "The destination folder path '" & dFolderPath & "' doesn't exist.", vbCritical: Exit Sub
End If
Dim r As Long, sFilePath As String, sPartialFileName As String, sFileName As String
Dim dFilePath As String, sExt As String 'extension (dot inclusive)
'_________________________________________________________________________________
Dim arrC, k As Long 'an array to keep the copied fileNames and a variable to keep
'the next array element to be loaded
Dim objFolder As Object: Set objFolder = fso.GetFolder(sPath)
ReDim arrC(objFolder.files.count) 'redim the array at the number of total files
'_________________________________________________________________________________
For r = 2 To lRow
sPartialFileName = CStr(ws.cells(r, Col).Value)
sExt = CStr(ws.cells(r, colExt).Value)
If Len(sPartialFileName) > 3 Then ' the cell is not blank
sFileName = Dir(sFolderPath & sPartialFileName & "*" & sExt)
Do While sFileName <> ""
If Len(sFileName) > 3 Then ' source file found
sFilePath = sFolderPath & sFileName
dFilePath = dFolderPath & sFileName
If Not fso.FileExists(dFilePath) Then ' the destination file...
fso.CopyFile sFilePath, dFilePath ' ... if doesn't exist...
'________________________________________________________________________
arrC(k) = sFileName: k = k + 1 'each copied file name is loaded in the array
'________________________________________________________________________
Else
'______________________________________________________________________
arrC(k) = sFileName: k = k + 1 'each copied file name is loaded in the array
'________________________________________________________________________
End If
End If
sFileName = Dir
Loop
End If
Next r
'__________________________________________________________________________________
If k > 0 Then ReDim Preserve arrC(k - 1) 'keep in the array only loaded elements
moveReminedFiles sPath, arrC
'_________________________________________________________________________________
End Sub
All modifications are between '_______________ lines
Copy the next Sub, which is called by the above one, in the same module:
Sub moveReminedFiles(sFolder As String, arr)
Dim fileName As String, mtch
Const destFolder As String = "E:\Uploading\Error Files\" 'use here your folder where errored files to be moved
If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
fileName = Dir(sFolder & "*.*")
Do While fileName <> ""
mtch = Application.match(fileName, arr, 0) 'if the file name does not exist in the array:
If IsError(mtch) Then Name sFolder & fileName As destFolder & fileName 'move it
fileName = Dir
Loop
End Sub
Please, test it and send some feedback. Of course, the bushy code could not be tested...
Edited:
Please, try the next updated (former) Sub which comes after the above code, moving all files in the Archive folder. Now, it should also do what you required in this question. Since it is not tested, you should send some feedback after testing it:
Sub moveAllFilesInDateFolderIfNotExist(sFolderPath As String, arr)
Dim DateFold As String, fileName As String, objFSO As Object, mtch
Const dFolderPath As String = "E:\Uploading\Archive\"
Const errFolder As String = "E:\Uploading\Error Files\"
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
DateFold = dFolderPath & "\" & Format(Date, "ddmmyyyy") & "\" ' create the cur date folder name
If Dir(DateFold, vbDirectory) = "" Then MkDir DateFold 'create the necessary folder if it does not exist
fileName = Dir(sFolderPath & "\*.*")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Do While fileName <> ""
mtch = Application.match(fileName, arr, 0)
If IsError(mtch) Then 'if the file name does not exist in the array:
If objFSO.FileExists(errFolder & "\" & fileName) Then
Kill errFolder & fileName
End If
Name sFolderPath & fileName As errFolder & fileName 'move it
Else
If Not objFSO.FileExists(DateFold & "\" & fileName) Then
Name sFolderPath & fileName As DateFold & fileName
Else
Kill DateFold & fileName
Name sFolderPath & fileName As DateFold & fileName
End If
End If
fileName = Dir
Loop
End Sub
You only have to change moveReminedFiles sPath, arrC with moveAllFilesInDateFolderIfNotExist sPath, arrC and run it. Take care that now it will also move the files in the archive folder. Of course, except the wrong spelled ones which will be moved in their special Error folder...
Please, send some feedback after testing it.
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
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
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
I am trying to loop through all text files in a folder, open each, do a find/replace, save each, and close each. My code looks like this.
Sub FindAndReplaceText()
Dim FileName As String
Dim FolderPath As String
Dim FSO As Object
Dim I As Integer
Dim SearchForWords As Variant
Dim SubstituteWords As Variant
Dim Text As String
Dim TextFile As Object
'Change these arrays to word you want to find and replace
SearchForWords = Array(" steps:" & "*" & " fields:")
SubstituteWords = Array(" global" & vbCrLf & " global:" & vbCrLf & " schema_def:" & vbCrLf & " fields:")
'Change the folder path to where your text files are.
' look for all lines with: ' - .*Pricing_RealEstate' & '*'
FolderPath = "C:\path_here\"
Set FSO = CreateObject("Scripting.FileSystemObject")
FolderPath = IIf(Right(FolderPath, 1) <> "\", FolderPath & "\", FolderPath)
FileName = Dir(FolderPath & "\*.txt")
Do While FileName <> ""
FileSpec = FolderPath & FileName
'Read all the file's text into a string variable.
Set TextFile = FSO.OpenTextFile(FileSpec, 1, False)
Text = TextFile.ReadAll
TextFile.Close
'Scan the string for words to replace and write the string back to the file.
Set TextFile = FSO.OpenTextFile(FileSpec, 2, False)
For I = 0 To UBound(SearchForWords)
Debug.Print Text
Replace Text, SearchForWords(I), SubstituteWords(I)
Debug.Print Text
Next I
TextFile.Write Text
TextFile.Close
FileName = Dir()
Loop
End Sub
This is tried and working with the sample data:
Sub FindAndReplaceText2()
Dim FileName, FileName2 As String
Dim FolderPath, FolderPath2 As String
Dim FileSpec, FileSpec2 As String
Dim FSO As Object
Dim SearchForWords As String
Dim SubstituteWords As String
Dim Text As String
Dim TextFile As Object
'Change these arrays to word you want to find and replace
SearchForWords = " steps:" & "*" & " fields:"
SubstituteWords = " global" & vbCrLf & " global:" & vbCrLf & " schema_def:" & vbCrLf & " fields:"
'Change the folder path to where your text files are.
' look for all lines with: ' - .*Pricing_RealEstate' & '*'
FolderPath = "C:\users\user\Desktop\New Folder\"
FolderPath2 = "C:\users\user\Desktop\New Folder2\"
Set FSO = CreateObject("Scripting.FileSystemObject")
FileName = Dir(FolderPath & "\*.txt")
Do While FileName <> ""
FileSpec = FolderPath & FileName
FileSpec2 = FolderPath2 & FileName
'Read all the file's text into a string variable.
Set TextFile = FSO.OpenTextFile(FileSpec, 1, False)
Text = TextFile.ReadAll
TextFile.Close
'SrchReplText Now work for single wildcard only
Text = SrchReplText(Text, SearchForWords, SubstituteWords)
'Scan the string for words to replace and write the string back to the file.
Set TextFile = FSO.CreateTextFile(FileSpec2, 2, False)
TextFile.Write Text
TextFile.Close
FileName = Dir()
Loop
End Sub
Private Function SrchReplText(Txt As String, SrcTxt As String, RplTxt As String) As Variant
'Now for single wildcard only using single loop
Dim Wordx, Word3 As Variant
Dim I, I2 As Long
SrchReplText = Txt
Wordx = Split(SrcTxt, "*")
If UBound(Wordx) > 1 Then Exit Function
If UBound(Wordx) = 1 Then
Do
Found = False
I = InStr(1, SrchReplText, Wordx(0))
If I > 0 Then I2 = InStr(I, SrchReplText, Wordx(1))
If I > 0 And I2 > 0 Then
Found = True
Word3 = Mid(SrchReplText, I, I2 - I + Len(Wordx(1)))
SrchReplText = Replace(SrchReplText, Word3, RplTxt, 1, 1)
End If
Loop While Found
Else
SrchReplText = Replace(SrchReplText, SrcTxt, RplTxt, 1, 1)
End If
End Function