Please advise - I wrote a code in VBA that iterates through files in certain directory, rename them, and write the status to Excel.
I would like to edit the code so that if the command Name returns error (For example if NewFileName already exists), then the parameter status would be "Fail", and continue to the next iteration. Could anyone help me how to do so?
Sub RenameFiles()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim directory As String
Dim OldFileName As String
Dim NewFileName As String
Dim illegal As String
Dim legal As String
Dim status As String
directory = (ThisWorkbook.Worksheets(4).Range("G6").Value) & "\"
illegal = (ThisWorkbook.Worksheets(4).Range("G8").Value)
legal = (ThisWorkbook.Worksheets(4).Range("G10").Value)
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(directory)
i = 1
'loops through each file in the directory and rename them
For Each objFile In objFolder.Files
OldFileName = objFile.Name
NewFileName = Replace(OldFileName, illegal, legal)
'Rename
Name directory & OldFileName As directory & NewFileName
'print old file name
Cells(i + 1, 1) = OldFileName
'print new file name
Cells(i + 1, 2) = NewFileName
'print new file path
Cells(i + 1, 3) = directory & NewFileName
'print status
If (OldFileName <> NewFileName) Then
status = "Success"
'Ifelse ()
Else
status = "No Change"
End If
Cells(i + 1, 3) = status
i = i + 1
Next objFile
End Sub
Related
I'm trying read a stack of saved .msg emails in a folder on a shared drive.
I can't get into Outlook to search directly because my organisation won't allow me to because it's a department shared email.
The saved folder is my workaround. I need to pull the file path and the date that we received the email from these files and put them into Excel. I can't take the date that the file was created because otherwise that'll be the date that I saved the file.
I managed to get the file path, but as soon as I try to get the received time it breaks.
I tried setting the ReceivedTime as an object, a string, a date.
If I Dim it as an object it whines that it's object not set, if I set the ReceivedTime it does the same.
If I dim it as string I get error 91, if I remove the with statement it still gives me error 91.
If I delete ReceivedTime = MailItem.ReceivedTime it moves on to the next time it's mentioned and yells at me about that part.
I checked my spelling of Received all through the code and that's not it.
Here's my code at the moment. I edited the file location for privacy. It works without the received time part, so the file location isn't the problem.
Sub FileSearchAlt()
Worksheets("Sheet1").Activate
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
Dim oMsg As Outlook.MailItem
Dim MailItem As Object
Dim ReceivedTime As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder("C:\Users\THE LOCATION OF MY FILE")
With oMsg
ReceivedTime = MailItem.ReceivedTime
For Each oFile In oFolder.Files
Cells(i + 1, 1) = "C:\Users\THE LOCATION OF MY FILE" & oFile.Name
Cells(i + 1, 2) = MailItem.ReceivedTime
i = i + 1
Next oFile
End With
End Sub
It seems you are trying to get OOM properties from MSG files saved to the disk:
Cells(i + 1, 2) = MailItem.ReceivedTime
In that case you need to open such files in Outlook and then read the properties using the Outlook object model. The OpenSharedItem method allows to open a shared item from a specified path or URL. This method is used to open iCalendar appointment (.ics) files, vCard (.vcf) files, and Outlook message (.msg) files. The type of object returned by this method depends on the type of shared item opened.
Dir allows access to files in desktop folders.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub FileSearchAlt()
Dim oApp As Object
Dim oNs As Object
Dim oFSO As Object
Dim desktopFolder As Object
Dim fPath As String
Dim fName As String
Dim fPathName As String
Dim i As Long
Dim oMsg As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
fPath = "C:\Users\THE LOCATION OF MY FILE"
'Dim enviro As String
'enviro = CStr(Environ("USERPROFILE"))
'fPath = enviro & "\Test\"
Debug.Print "fPath........: " & fPath
If Right(fPath, 1) <> "\" Then
fPath = fPath & "\"
Debug.Print "with backslash added"
Debug.Print "fPath........: " & fPath
End If
Set desktopFolder = oFSO.GetFolder(fPath)
Debug.Print "desktopFolder: " & desktopFolder.Name
Set oApp = CreateObject("Outlook.Application")
Set oNs = oApp.getnamespace("MAPI")
Debug.Print "Dir parameter: " & fPath & "*.msg"
fName = Dir(fPath & "*.msg")
Debug.Print "fName........: " & fName
Do While fName <> ""
fPathName = fPath & fName
Debug.Print "fPathName....: " & fPathName
Set oMsg = oNs.OpenSharedItem(fPathName)
With Worksheets("Sheet1")
.Cells(i + 1, 1) = fPathName
.Cells(i + 1, 2) = oMsg.receivedTime
i = i + 1
End With
fName = Dir
Debug.Print "fName........: " & fName
Loop
Debug.Print "Done."
End Sub
I want copy pdf from source folder and have to paste in destpath based on Excel, help me where I am gone wrong
Sub CheckandSend()
Dim irow As Integer
Dim DestPath As String
Dim SourcePath As String
Dim pfile As String
Dim FSO As Object
Dim Fldr As Object, f As Object
SourcePath = "I:\Mechanical\ExternalProjects\Cummins Emission Systems\35101124 PT Cup Test Rig\16 PDF to Vendor"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Fldr = FSO.GetFolder(SourcePath).Files
DestPath = "P:\CENTRAL PLANNING\PROJECTS 2020-2021\VAM-TARSON\Newfolder1"
irow = 7
Do While Cells(irow, 2) <> Empty
pfile = Dir(SourcePath & "\*" & Cells(irow, 2) & "*")
If pfile <> "" And Right(pfile, 3) = "PDF" Then
FileCopy SourcePath, DestPath
irow = irow + 1
End If
Loop
end sub
You are mixing 2 different methods: The FileSystemObject and Dir(). Only use one of them.
FileCopy SourcePath, DestPath only copies the path but there is no filename.
Directly include the file extension in your Dir() so you don't need to check for pdf files:
FileName = Dir(SourcePath & "*" & ws.Cells(iRow, 2) & "*.pdf")
There may exist more than one file with the key word from your cell. Your code copies randomly one of them. Make sure to loop so you get all of them
Do While FileName <> vbNullString 'if more files with the key word from ws.Cells(iRow, 2) exist copy all of them
VBA.FileCopy SourcePath & pfile, DestPath 'copy needs to be path AND filename
FileName = Dir()
Loop
It could look like this:
Option Explicit
Public Sub CheckandSend()
Dim ws As Worksheet 'make sure to define a sheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim SourcePath As String
SourcePath = "C:\Temp\" 'make sure paths end with \
Dim DestPath As String
DestPath = "P:\CENTRAL PLANNING\PROJECTS 2020-2021\VAM-TARSON\Newfolder1\" 'make sure paths end with \
Dim iRow As Long
iRow = 7
Do While ws.Cells(iRow, 2) <> vbNullString
Dim FileName As String
FileName = Dir(SourcePath & "*" & ws.Cells(iRow, 2) & "*.pdf") 'this will only go through pdf files
Do While FileName <> vbNullString 'if more files with the key word from ws.Cells(iRow, 2) exist copy all of them
VBA.FileCopy SourcePath & pfile, DestPath 'copy needs to be path AND filename
FileName = Dir()
Loop
iRow = iRow + 1
Loop
End Sub
The code below works.
Sub CheckandSend()
' 191
Const Ext As String = ".pdf"
Dim SourcePath As String
Dim DestPath As String
Dim FSO As Object
Dim Fldr As Object
Dim pFile As String
Dim f As Object
Dim iRow As Long ' row numbers should be declared as Long
' both paths must end on backslash ("\")
SourcePath = "I:\Mechanical\ExternalProjects\Cummins Emission Systems\35101124 PT Cup Test Rig\16 PDF to Vendor\"
DestPath = "P:\CENTRAL PLANNING\PROJECTS 2020-2021\VAM-TARSON\Newfolder1\"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Fldr = FSO.GetFolder(SourcePath).Files
' loop until last used cell in column B
For iRow = 7 To Cells(Rows.Count, 2).End(xlUp).Row
pFile = Trim(Cells(iRow, 2).Value)
If Len(pFile) = 0 Then Exit For ' exit at first blank row
If LCase(Right(pFile, 4)) <> Ext Then pFile = pFile & Ext
If Len(Dir(SourcePath & pFile)) Then
FileCopy SourcePath & pFile, DestPath & pFile
End If
Next iRow
End Sub
There are a few inconsistencies in your procedure which I have eliminated. For example, your code isn't clear whether the file name in the worksheet has a pdf extension or not, then looks for any file by that name but rejects all that aren't "pdf". The above code rephrases this to mean that you want a PDF file by the name in the worksheet and any file by the same name but another extension is to be ignored. It's the same, I think, but more efficient if you limit the search to PDF.
The other thing is the end of the loop. Is it when there are no more file names or when a cell is blank? The above code ends in either case. I presume that is OK because there are no blanks in your list of files. If so, it would be better, however, to just skip any accidental blanks and continue until the last line has been processed. If you agree, delete the Exit For and set an End If at the appropriate point (before the Next iRow) and indent all lines in between.
I am trying to select a folder and then assign that path to my file Variant. However, the code stops after the folder is selected and does not go to the next step. What can be wrong? The next step would be 'If selected_folder <> "" Then' but it just stops and debugger goes back to Sub.
Sub sheetCompare2()
Application.ScreenUpdating = False
Dim i As Integer
Dim WS_Count As Integer
Dim mDirs As String
Dim path As String
Dim OutFile As Variant, SrcFile As Variant
Dim file As Variant
Dim wb As Workbook
Dim datevar As Variant
Dim datevar2 As Variant
Dim selected_folder As String
Set wb = ThisWorkbook
WS_Count = ActiveWorkbook.Worksheets.Count
OutFile = ActiveWorkbook.Name
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
If Application.FileDialog(msoFileDialogFolderPicker).Show = -1 Then
selected_folder = .SelectedItems(1)
End If
End With
If selected_folder <> "" Then
file = Dir(selected_folder)
End If
While (file <> "")
path = selected_folder + file
Workbooks.Open (path)
SrcFile = ActiveWorkbook.Name
datevar = Right(file, 9)
datevar2 = Left(datevar, 4)
....'and so on
End Sub
Please, try changing this part of the code:
If selected_folder <> "" Then
file = Dir(selected_folder)
End If
While (file <> "")
path = mDirs + file
Workbooks.Open (path)
SrcFile = ActiveWorkbook.Name
datevar = Right(file, 9)
datevar2 = Left(datevar, 4)
'....'and so on
with:
If selected_folder <> "" Then
File = Dir(selected_folder & "\" & "*.xls*")
End If
Do While File <> ""
path = selected_folder & "\" & File
Workbooks.Open (path)
SrcFile = ActiveWorkbook.Name
datevar = Right(File, 9)
datevar2 = left(datevar, 4)
File = Dir
'...
Loop
In order to make Dir return a file name, you must set an extension. At least *.* for iterate between all files. But, wanting to open the files in Excel, it is good to use "*.xls*", as the above code does.
Then, the path of the file to be open should be built as above.
Your code does not show how you redefine File in order to make the loop working. You maybe have File = Dir before the loop end. If not, I added...
Im trying to come up with a piece of script that will allow me to copy 100 files from one folder and create a new folder based on the first file and last file name and then move those 100 files to that folder.
After moving those files, i want it to display the folders in a userform listbox as clickable items.
For example, each item in the listbox will be a folder, if i double click on a folders name it will display all the contents of the file (of each of 100 files) in a sheet i've set up.
I haven't been able to test this code yet, all i've done for the past week was research and rewrite the code over and over until i could understand it properly before adding it to the program. So there's bound to be some or more errors along the way.
What i did notice was the "objFile.CopyFile Folderpath & FCount & "_" & LCount" piece of code that doesnt specify which files could be copied specifically. For example, i want it to start at the first file and start coping the first 100 files, when the code is executed again, it will start at file 101 and copy the next 100 files. If there's way to ensure that it wouldnt keep copying the first 100 files, that would be awesome!
Sub Main()
'====CHECK IF THERE'S 100 FILES====
Dim filename, folderpath, path As String
Dim count As Integer
Dim FCount, LCount, FlagCount, IntCount As Integer
Dim objFSO As Object
Dim obj As Object
FCount = 0 ' First File name
LCount = 0 'Last file name
count = 0 'file count
FlagCount = Sheets("Flag Sheet").Range("A2").Value
folderpath = "Work\Big Book\" '==================Location Of The Book
path = folderpath & "*.xls"
filename = Dir(path)
Do While filename <> ""
count = count + 1
filename = Dir(path)
Loop
If count < 100 Then
'====CREATE A FOLDER FOR THE FILES====
If FlagCount <> "" Then '====If there is a flag count, it will create a folder based on the last number it was used
FCount = FlagCount + 1
LCount = FlagCount + 101
MkDir folderpath & FCount & "_" & LCount
Else '=======================else if there isnt one, it will use the first file name to create the folder
FCount = IntCount + 1
LCount = IntCount + 100
MkDir folderpath & FCount & "_" & LCount
End If
'====MOVE 100 FILES TO FOLDER====
For Each objFile In objFSO.GetFolder(path)
If FlagCount <> "" Then '====================if theres a flag count it will move the files starting after the flag count + 101
objFile.CopyFile folderpath & FCount & "_" & LCount
IntCount = FlagCount + 1
If IntCount = FlagCount + 100 Then Exit For
Else '======================================else it will just move the first 100 files
objFile.CopyFile folderpath & FCount & "_" & LCount
IntCount = IntCount + 1
If IntCount = IntCount + 100 Then Exit For
End If
Next
End If
Else
'===Do Nothing===
End If
End Sub
'=====Display Folders In Listbox=====
'====Display Folder Items In Book====
'Call the function
DisplayFoldersInListBox folderpath & FCount & "_" & LCount, Me.Listbox1
Sub Button_Click()
For Each File in Folderpath & FCount & "_" & LCount & "\" & Listbox.value
'[INSERT BIG BOOK CODE]
Next
End Sub
Private Sub DisplayFoldersInListBox(ByVal strRootFolder As String, ByRef lbxDisplay As MSForms.ListBox)
Dim fso As Object
Dim fsoRoot As Object
Dim fsoFolder As Object
'Make sure that root folder contains trailing backslash
If Right$(strRootFolder, 1) <> "\" Then strRootFolder = strRootFolder & "\"
'Get reference to the FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
'Get the root folder
Set fsoRoot = fso.GetFolder(strRootFolder)
'Clear the listbox
lbxDisplay.Clear
'Populate the listbox with subfolders of Root
For Each fsoFolder In fsoRoot.SubFolders
lbxDisplay.AddItem fsoFolder.Name
Next fsoFolder
'Clean up
Set fsoRoot = Nothing
Set fso = Nothing
End Sub
This link: Copy only the first file of a folder VBA
Seems to be the answer for the coping of the files, but im not entirely sure how to add it to my script. Can anyone help me out?
Back to the basics:
CopyXNumberOfFiles:Sub
Sub CopyXNumberOfFiles(SourceFolder As String, TargetFolder As String, Optional MaxNumFiles As Long = 100)
Dim fso As Object, objFile As Object
Dim count As Long
Dim Path As String
Set fso = CreateObject("Scripting.FileSystemObject")
If Not Right(SourceFolder, 1) = "\" Then SourceFolder = SourceFolder & "\"
If Not Right(TargetFolder, 1) = "\" Then TargetFolder = TargetFolder & "\"
For Each objFile In fso.GetFolder(SourceFolder).Files
If objFile.Path Like "*.xls?" Then
Path = TargetFolder & objFile.Name
If Len(Dir(Path)) = 0 Then
FileCopy objFile.Path, Path
count = count + 1
If count >= MaxNumFiles Then Exit For
End If
End If
Next
End Sub
Usage
CopyXNumberOfFiles "C:\","C:\Data"
Addendum
This function will copy the files over and return an array of the new file paths.
Function getCopyXNumberOfFiles(SourceFolder As String, TargetFolder As String, Optional MaxNumFiles As Long = 100) As String()
Dim fso As Object, objFile As Object
Dim count As Long, n As Long
Dim Path As String
Dim data() As String, results() As String
ReDim data(1 To 2, 1 To MaxNumFiles)
Set fso = CreateObject("Scripting.FileSystemObject")
If Not Right(SourceFolder, 1) = "\" Then SourceFolder = SourceFolder & "\"
If Not Right(TargetFolder, 1) = "\" Then TargetFolder = TargetFolder & "\"
For Each objFile In fso.GetFolder(SourceFolder).Files
If objFile.Path Like "*.xls?" Then
Path = TargetFolder & objFile.Name
If Len(Dir(Path)) = 0 Then
FileCopy objFile.Path, Path
count = count + 1
data(1, count) = objFile.Path
data(2, count) = Path
If count >= MaxNumFiles Then Exit For
End If
End If
Next
ReDim Preserve results(1 To count, 1 To 2)
For n = 1 To count
results(n, 1) = data(1, n)
results(n, 2) = data(2, n)
Next
getCopyXNumberOfFiles = results
End Function
Usage
Column 1 has the original paths and column 2 has the new paths.
Dim Files() as String, firstFilePath as String, lastFilePath as String
Files = getCopyXNumberOfFiles("C:\", "C:\New Folder\", 100)
Original Paths
firstFilePath = Files(1, 1)
lastFilePath = Files(Ubound(Files), 1)
New Paths
firstFilePath = Files(1, 2)
lastFilePath = Files(Ubound(Files), 2)
I have created a code to give me path and there names for all the files in a folder to excel.
But my problem is its giving me file names of all the files in that folder. I just want to search and retrieve names of only pdf files to excel.
Here is what I have:
Sub Example1()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(Range("H1").Value)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file path
Cells(i + 3, 2) = objFile.Path
i = i + 1
Next objFile
End Sub
As per the comments. You need to test if the last three characters are 'pdf'
So in your for loop add the if statement
For Each objFile In objFolder.Files
if right(objFile.Path,3) = "pdf" then
'print file path
Cells(i + 3, 2) = objFile.Path
i = i + 1
end if
Next objFile
This should work:
Sub Find_PDF()
Dim FileToCheck As String, FilePath As String, FileWildCard As String
FilePath = "c:\YOUR FILE PATH\"
FileWildCard = "*.pdf"
FileToCheck = Dir(FilePath & FileWildCard)
Do While FileToCheck <> ""
i = i + 1
Sheets("Sheet1").Range("A" & i).Value = FileToCheck
FileToCheck = Dir()
Loop
End Sub
This is not a free coding service but i would answer this anyway:
For Each objFile In objFolder.Files
if right(objFile.Path,3) = "pdf" then
'print file path
Cells(i + 3, 2) = objFile.Path
i = i + 1
end if
msgbox ("Answer are here dont troll on someone")
Next objFile