I'm preparing a code which would every month help users rename specific string in multiple files.
Example: from "Jan" to "Feb", from "Bank" to "Cash", from "Test" to "Sharp" etc. (Bank Statement Jan.xls -> JPM Statement Jan.xls, Form test.xls -> Form sharp.xls, etc.)
I use a function to populate files from all folders and also subfolder picked up a FileDialog, then I prompt the user to InputBox string to be found and string to be replaced in the file name.
Sub testrenametest()
Dim filedlg As FileDialog
Dim xPath As String
Dim fileList As Object
Dim vFile As Variant
Dim FindTerm As String, ReplaceTerm As String, NewFileName As String
Set filedlg = Application.FileDialog(msoFileDialogFolderPicker)
With filedlg
.Title = "Please select folder"
.InitialFileName = ThisWorkbook.Path
If .Show <> -1 Then End
xPath = .SelectedItems(1) & "\"
End With
FindTerm = InputBox("Find string:") ReplaceTerm = InputBox("Replace with:")
Set fileList = getFileList(xPath)
For Each vFile In fileList
If vFile Like "*" & FindTerm & "*" Then
NewFileName = Replace(vFile, FindTerm, ReplaceTerm)
Name vFile As NewFileName
End If
Next vFile
End Sub
Function getFileList(Path As String, Optional FileFilter As String = "*.*", Optional fso As Object, Optional list As Object) As Object
Dim BaseFolder As Object, oFile As Object
If fso Is Nothing Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set list = CreateObject("System.Collections.ArrayList")
End If
If Not Right(Path, 1) = "\" Then Path = Path & "\"
If Len(Dir(Path, vbDirectory)) = 0 Then
MsgBox "You need to browse folder first!"
End
End If
Set BaseFolder = fso.GetFolder(Path)
For Each oFile In BaseFolder.SubFolders
getFileList oFile.Path, FileFilter, fso, list
Next
For Each oFile In BaseFolder.Files
If oFile.Path Like FileFilter Then list.Add oFile.Path
Next
Set getFileList = list
End Function
It works for some strings like month names but for instance for "test" or "bank" doesn't. It says Run-time error 53 File not found on line Name vFile As NewFileName, but the file exists. Sorry for inputting the whole code, but I am unable to pinpoint where might be a problem.
Your problem probably lies in the fact that it is attempting to rename a file inside the loop that no longer exists with that name. Condition the rename by first double-checking to make sure the file still exists.
For Each vFile In fileList
If vFile Like "*" & FindTerm & "*" Then
NewFileName = Replace(vFile, FindTerm, ReplaceTerm)
If Dir$(vFile) <> "" Then
Name vFile As NewFileName
End If
End If
Next vFile
Edit: after additional feedback was provided that the problem is that the replaced string was also found in the path, I suggest the following fix:
For Each vFileSpec In fileList
vPath = Left(vFile, InstrRev(vFileSpec, "\") - 1)
vFile = Mid(vFileSpec, Len(vPath) + 1)
If vFile Like "*" & FindTerm & "*" Then
NewFileName = Replace(vFile, FindTerm, ReplaceTerm)
Name vFileSpec As vPath + "\" + NewFileName
End If
Next vFile
Related
I need to look in a specific folder and find the last file saved and move(or copy) to an other folder using VBA.
by finding the file i'm using:
Private Function fFindLastFile()
'Call GetFolder
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim myFolder As Object
Set myFolder = fso.GetFolder("D:\SF\C0T460A220000042\")
'Set myFolder = fso.GetFolder(GetFolder)
Dim myFile As Object
Set myFile = myFolder.Files.Item(myFolder.Files.Count) '<----- this is where i get a debug nr 5, unknown procedure or argument
MsgBox myFile.Name & " was last modified on " & myFile.DateLastModified
End Function
I don not have the name or type of the file that i'm looking for, but i just downloaded it from a known URL.
do you have any ideas what i'm doing wrong?
Last Modified File (FileSystemObject)
Option Explicit
Private Sub CopyLastFile()
Const sFolderPath As String = "D:\SF\C0T460A220000042\"
Const dFolderPath As String = "C:\Test\" ' adjust!
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
Dim fsoFolder As Object: Set fsoFolder = fso.GetFolder(sFolderPath)
Dim fsoFile As Object, fName As String, fDate As Date
For Each fsoFile In fsoFolder.Files
If fsoFile.DateLastModified > fDate Then
fName = fsoFile.Name
fDate = fsoFile.DateLastModified
End If
Next fsoFile
If Len(fName) > 0 Then
fso.CopyFile sFolderPath & fName, dFolderPath, True
'fso.MoveFile sFolderPath & fName, dFolderPath, True
MsgBox "File Name: " & fName & vbLf & "Last modified: " & fDate, _
vbInformation, "Last Modified File"
Else
MsgBox "No file found.", vbExclamation, "Last Modified File"
End If
End Sub
I need to do the following:
Allow the user to select any number of files, in any format, and copy them to a new folder.
Create the destination folder if it doesn't exist. In this case, the folder name should be given by the content of the C2 & C3 cells (Range("C2").Value & Range("C3").Text & "\").
Private Sub CommandButton4_Click()
Dim strDirname As String
Dim strDefpath As String
Dim strPathname As String
Dim strFilename As String
Dim FSO
Dim sFile As FileDialog
Dim sSFolder As String
Dim sDFolder As String
strDirname = Range("C2").Value & Range("C3").Text
MkDir strDefpath & "\" & strDirname
strPathname = strDefpath & "\" & strDirname & "\" & strFilename
Set sFile = Application.FileDialog(msoFileDialogOpen)
sDFolder = strDirname & "\"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FSO = New FileSystemObject
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
If Not .Show Then Exit Sub
Set xFolder = FSO.GetFolder(.SelectedItems(1))
For Each xFile In xFolder.Files
On Error Resume Next
xRow = Application.Match(xFile.Name, Range("A:A"), 0)
On Error GoTo 0
Next
End With
End Sub
I know the error is here...
Set xFolder = FSO.GetFolder(.SelectedItems(1))
...because I'm asking it to get a file, not a folder.
It is not very clear to me what you are trying to do but, if you intend to select a folder, you have to use it
Application.FileDialog (msoFileDialogFolderPicker)
instead of
Application.FileDialog (msoFileDialogFilePicker)
Your posted code shows so little resemblance to what you Q asks for, I've disregarded it.
This code follows the description. You may need to alter certain details to fully match your needs
Sub Demo()
Dim FilePicker As FileDialog
Dim DefaultPath As String
Dim DestinationFolderName As String
Dim SelectedFile As Variant
Dim DestinationFolder As Folder
Dim FSO As FileSystemObject
DefaultPath = "C:\Data" ' <~~ update to suit, or get it from somewhere else
' Validate Default Path
If Right$(DefaultPath, 1) <> Application.PathSeparator Then
DefaultPath = DefaultPath & Application.PathSeparator
End If
If Not FSO.FolderExists(DefaultPath) Then Exit Sub
' Get Destination Folder, add trailing \ if required
DestinationFolderName = Range("C2").Value & Range("C3").Value
If Right$(DestinationFolderName, 1) <> Application.PathSeparator Then
DestinationFolderName = DestinationFolderName & Application.PathSeparator
End If
Set FSO = New FileSystemObject
' Get reference to Destination folder, create it if required
If FSO.FolderExists(DefaultPath & DestinationFolderName) Then
Set DestinationFolder = FSO.GetFolder(DefaultPath & DestinationFolderName)
Else
Set DestinationFolder = FSO.CreateFolder(DefaultPath & DestinationFolderName)
End If
' File Selection Dialog
Set FilePicker = Application.FileDialog(msoFileDialogFilePicker)
With FilePicker
.AllowMultiSelect = True ' allow user to select multiple files
.InitialFileName = DefaultPath ' set initial folder for dialog
If .Show = False Then Exit Sub ' check if user cancels
For Each SelectedFile In .SelectedItems ' loop over selected files
If SelectedFile Like DefaultPath & "*" Then 'Optional: disallow browsing higher than default folder
FSO.CopyFile SelectedFile, DefaultPath & DestinationFolderName, True ' Copy file, overwrite is it exists
End If
Next
End With
End Sub
I'm completely new to VBA and had some trouble googling this problem cause variable has multiple meanings.
I am trying to open a file and assign its name to a variable. The file's name is never the same though I always download it to the same folder (one file in that folder only). The only recognizable thing about the file are 3 letters "ABC".
So far I managed to get opening the file to work but not assigning the non-standardized file name to a variable.
Sub openwb()
Dim wb As Workbook Dim directory As String
directory = "D:\Users\AAA\Desktop\Practice"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set folder = FSO.GetFolder(directory)
For Each file In folder.Files
If Mid(file.Name, InStrRev(file.Name, ".") + 1) = "xlsm" Then
Workbooks.Open directory & Application.PathSeparator & file.Name
End If
Next file
End Sub
Public Sub RecordFileName()
Dim sPath As String, sFile As String
Dim wb As Workbook
sPath = "D:\Users\AAA\Desktop\Practice"
sFile = sPath & "*ABC*"
End Sub
Here is a function you can use. It will return the filename you are looking for, and you can specify a file pattern if you want to, or you can omit that argument and it will assume all files.
Function GetFullFileName(sFolder As String, Optional sPattern As String = "*") As String
Dim sFile As String
' ensure sFolder ends with a backslash
If Right$(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
sFile = Dir(sFolder & sPattern)
If sFile = "" Then
MsgBox "NOT FOUND: " & sFolder & sPattern
End
End If
GetFullFileName = sFolder & sFile
End Function
Usage:
MsgBox GetFullFileName("C:\Users\Fred\Documents")
Or
MsgBox GetFullFileName("C:\Users\Fred\Documents\", "*ABC*.xlsm")
Or
sFullFile = GetFullFileName("C:\Users\Fred\Documents\", "*ABC*.xlsm")
I want to copy specific file type(*.SLDDRW) from source to destination,in destination path we have lots of folders and sub-folders .in below code i am trying to walk on any sub folders but unfortunately it didn't work and didn't walk all sub-folders S.O can help me?
Sub copy_specific_files_in_folder()
Dim FSO As Object
Dim sourcePath As String
Dim destinationPath As String
Dim fileExtn As String
sourcePath = "C:\Users\6\"
destinationPath = "C:\Users\"
fileExtn = "*.SLDDRW"
If Right (sourcePath, 1) <> "\" Then
sourcePath = sourcePath & "\"
End If
Set FSO = CreateObject ("scripting.filesystemobject")
If FSO.FolderExists(sourcepath) = False Then
MsgBox sourcePath & " does not exist"
Exit Sub
End If
FSO.CopyFile Source:=sourcePath & fileExtn, Destination :=destinationPath
copy_files_from_subfolders
MsgBox "Your files have been copied from the sub-folders of " & sourcePath
End sub
sub copy_files_from_subfolders()
Dim FSO AS Object , fld As Object
Dim fsoFile As Object
Dim fsoFol As Object
sourcePath = "C:\Users\6\"
targetPath = "C:\Users\"
If Right (sourcePath , 1) <> "\" then sourcePath = sourcePath & "\"
Set FSO = createObject("Scripting.FileSystemObject")
Set fld = FSO.getFolder(sourcePath)
If FSO.FolderExists(fld) Then
For Each fsoFol In FSO.GetFolder(sourcePath).SubFolders
For Each fsoFile In fsoFol.Files
If Right (fsoFile, 6) = "sldprt" Then
fsoFile.Copy targetPath
End If
Next
Next
End If
Here's a function that will recursively search a folder and all subfolders for a specific extension and then copy found files to a specified destination:
Sub SearchFoldersAndCopy(ByVal arg_sFolderPath As String, _
ByVal arg_sDestinationFolder As String, _
ByVal arg_sExtension As String)
Dim oFSO As Object
Dim oFolder As Object
Dim oSubFolder As Object
Dim sTest As String
'Test if FolderPath exists
sTest = Dir(arg_sFolderPath, vbDirectory)
If Len(sTest) = 0 Then
MsgBox "Specified folder [" & arg_sFolderPath & "] doesn't exist. Please check spelling or create the directory."
Exit Sub
End If
'Test if Destination exists
sTest = Dir(arg_sDestinationFolder, vbDirectory)
If Len(sTest) = 0 Then
MsgBox "Specified destination [" & arg_sDestinationFolder & "] doesn't exist. Please check spelling or create the directory."
Exit Sub
End If
'FolderPath and Destination both exist, proceed with search and copy
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(arg_sFolderPath)
'Test if any files with the Extension exist in directory and copy if one or more found
sTest = Dir(oFolder.Path & Application.PathSeparator & "*." & arg_sExtension)
If Len(sTest) > 0 Then oFSO.copyfile oFolder.Path & Application.PathSeparator & "*." & arg_sExtension, arg_sDestinationFolder
'Recursively search subfolders
For Each oSubFolder In oFolder.SubFolders
SearchFoldersAndCopy oSubFolder.Path, arg_sDestinationFolder, arg_sExtension
Next oSubFolder
End Sub
Here's an example of how to call it:
Sub tgr()
Dim sStartFolder As String
Dim sDestination As String
Dim sExtension As String
sStartFolder = "C:\Test"
sDestination = "C:\Output\" '<-- The ending \ may be required on some systems
sExtension = "SLDDRW"
SearchFoldersAndCopy sStartFolder, sDestination, sExtension
End Sub
Can anyone please review code below and tell me where am I going wrong?
Basically what I am trying to achieve, user inputs name in the Column A, then will click upload button (same row, column F), excel would create a folder using name from Column A, via filedialog window user will select multiple files which should be copied to newly created folder, finally excel would also additionally create path to the folder (saved in column D) and stamp the date (column E).
Current problems:
Fails to copy multiple files, currently I can only copy one file
File is copied to parent folder of newly created folders, basically
fails to copy to newly created folder itself.
My code:
Sub Button1_Click()
Dim objFSO As Object
Dim objFile As Object
Dim openDialog As FileDialog
Dim Foldername As String
Dim Path As String
Dim Newpath As String
Dim i As Integer
Dim myfile As String
Dim myfilePath As String
Foldername = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -5).Value
Path = "C:\Test\"
Set openDialog = Application.FileDialog(msoFileDialogFilePicker)
openDialog.AllowMultiSelect = True
Set objFSO = CreateObject("Scripting.FileSystemObject")
For i = 1 To openDialog.SelectedItems.Count
myfile = openDialog.SelectedItems.Item(i)
Next
If openDialog.Show = -1 Then
If Dir(Path & Foldername, vbDirectory) = "" Then
MkDir Path & Foldername
End If
objFSO.CopyFile myfile, Path
ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -2).Hyperlinks.Add ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -2), Address:=Path & Foldername, TextToDisplay:="Open Folder"
ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -1).Value = Format(Now, "MM/dd/yyyy")
MsgBox "Files were successfully copied"
End If
End Sub
Your For loop was in the wrong place. This is why you were not able to loop through every file and copy it.
You have this problem, because you used objFSO.CopyFile myfile, Path instead of the newly created folder name. I changed that part with this: objFSO.CopyFile myfile, Path & Foldername & "\" . Note that Path & Foldername is not enough, as you need to have \ at the end.
The working code:
Sub Button1_Click()
Dim objFSO As Object
Dim objFile As Object
Dim openDialog As FileDialog
Dim Foldername As String
Dim Path As String
Dim Newpath As String
Dim i As Integer
Dim myfile As String
Dim myfilePath As String
Foldername = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -5).Value
Path = "C:\Test\"
Set openDialog = Application.FileDialog(msoFileDialogFilePicker)
openDialog.AllowMultiSelect = True
Set objFSO = CreateObject("Scripting.FileSystemObject")
If openDialog.Show = -1 Then
If Dir(Path & Foldername, vbDirectory) = "" Then
MkDir Path & Foldername
End If
For i = 1 To openDialog.SelectedItems.Count
myfile = openDialog.SelectedItems.Item(i)
objFSO.CopyFile myfile, Path & Foldername & "\"
Next
ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -2).Hyperlinks.Add ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -2), Address:=Path & Foldername, TextToDisplay:="Open Folder"
ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -1).Value = Format(Now, "MM/dd/yyyy")
MsgBox "Files were successfully copied"
End If
Set objFSO = Nothing
Set openDialog = Nothing
End Sub