I am working with a code which can extract entire path of a pdf files and display of active workbook.
But problem is the extracted files are not hyperlinked i.e. I cant open the files directly on clicking on the that cell. Is there any way it gets automatically hyperlinked so that one click opens the files directly from excel.
Below is the code:
Sub ReadFiles()
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("C1").Value)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
If Right(objFile.Path, 3) = "pdf" Then
'print file path
Cells(i + 2, 13) = objFile.Path
i = i + 1
End If
Next objFile
End Sub
This should work, replace "WorksheetName" with the name of your worksheet:
Sub ReadFiles()
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("C1").Value)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
If Right(objFile.Path, 3) = "pdf" Then
'print file path
Cells(i + 2, 13) = objFile.Path
Sheets("WorksheetName").Hyperlinks.Add _
Anchor:= Sheets("WorksheetName").Cells(i + 2, 13), _
Address:= objFile.Path
i = i + 1
End If
Next objFile
End Sub
After you print file path add this: cells(i + 2,13).select ActiveCell.Hyperlinks.Add ActiveCell, ActiveCell
Related
Here is my problem, on my excel sheet I put paths of every folder that I want to check
V:\Folder1\
V:\Folder2\
Inside those folder I want vba to give me the name of the last modified file based on a specific name.
I will give an example:
In my folder1 I have those files :
Lo_2021_1
Lo_Full_2021_1
Lo_2021_2
Lo_Full_2021_2
...
Lo_2021_50
Lo_Full_2021_50
In my folder2 I have those files :
Li_2021_1
Li_Full_2021_1
Li_2021_2
Li_Full_2021_2
...
Li_2021_50
Li_Full_2021_50
I want vba to give me the name of the last modified file that starts with Lo_2021 in my folder1 and Li_2021 in my folder2 (so I don't want Lo_Full and Li_Full)
I already created a code that gave me the name of the last modified files but they are Lo_Full_2021_50 and Li_Full_2021_50 whereas I want Lo_2021_50 and Li_2021_50
Here is my code :
Option Explicit
Sub name_last_file()
Dim FileSys As FileSystemObject
Dim objFile As File
Dim myFolder
Dim strFilename As String
Dim dteFile As Date
Dim list_path As Range
Dim path_ As Range
Dim myDir As String
Set list_path = Range("B2", Range("B2").End(xlDown))
For Each path_ In list_path
myDir = path_.Value
'set up filesys objects
Set FileSys = New FileSystemObject
Set myFolder = FileSys.GetFolder(myDir)
'loop through each file and get date last modified. If largest date then store Filename
dteFile = DateSerial(1900, 1, 1)
For Each objFile In myFolder.Files
If objFile.DateLastModified > dteFile Then
dteFile = objFile.DateLastModified
strFilename = objFile.Name
End If
Next objFile
MsgBox strFilename
Next path_
End Sub
This will give me Lo_Full_2021_50 and Li_Full_2021_50 whereas I want Lo_2021_50 and Li_2021_50.
Is there a way to say that I want the last modified file that start with Lo_2021 or Li_2020 so that I will get Lo_2021_50 and Li_2021_50 as a result ?
I'm really thankful for your help
Please, test the next updated code:
Sub Give_name_files()
Dim FileSys As FileSystemObject, objFile As File, myFolder As oobject
Dim strFilename As String, dteFile As Date, list_path As Range, path_ As Range
Dim strRoot As String
strRoot = "Lo_2021" 'the beginning of the tested files name
'First I Select paths that are on my excel cells
Set list_path = Range("B2", Range("B2").End(xlDown))
For Each path_ In list_path
myDir = path_.Value
'Set up filesys objects
Set FileSys = New FileSystemObject
Set myFolder = FileSys.GetFolder(myDir)
'loop through each file and get date last modified. If largest date then store Filename
dteFile = DateSerial(1900, 1, 1)
For Each objFile In myFolder.Files
If left(objFile.Name, Len(strRoot)) = strRoot Then
If objFile.DateLastModified > dteFile Then
dteFile = objFile.DateLastModified
strFilename = objFile.Name
End If
End If
Next objFile
MsgBox strFilename
Next path_
End Sub
Hi I am trying to open the latest file (date modified) in a folder. The code uses a loop to go through the files and find the latest modified which it does however when it comes to open the file using 'Workbooks.Open strFilename' it says the file (which it has already identified as the 'youngest' file could not be found. This doesn't make sense to me as the error message says the file 'test young' - the file name could not be found, but it clearly found it during the loop.
Sub copynewdata()
Dim FileSys As FileSystemObject
Dim objFile As File
Dim myFolder
Dim strFilename As String
Dim dteFile As Date
Dim Ref As Object, CheckRefEnabled%
CheckRefEnabled = 0
With ThisWorkbook
For Each Ref In .VBProject.References
If Ref.Name = "Scripting" Then
CheckRefEnabled = 1
Exit For
End If
Next Ref
If CheckRefEnabled = 0 Then
.VBProject.References.AddFromGUID "{420B2830-E718-11CF-893D-00A0C9054228}", 1, 0
End If
End With
'set path for files - change for your folder
Const myDir As String = "\\C:\Test"
'set up filesys objects
Set FileSys = New FileSystemObject
Set myFolder = FileSys.GetFolder(myDir)
'loop through each file and get date last modified. If largest date then store Filename
dteFile = DateSerial(1900, 1, 1)
For Each objFile In myFolder.Files
If objFile.DateLastModified > dteFile Then
dteFile = objFile.DateLastModified
strFilename = objFile.Name
End If
Next objFile
Workbooks.Open strFilename
'Set Source_Workbook = Workbooks(strFilename).Open(Target_Path)
Set FileSys = Nothing
Set myFolder = Nothing
End Sub
Can anyone help with this?
In strFilename, you have the name of the file - but without the path. Change the open-command to
Workbooks.Open myDir & "\" & strFilename
I want to open all of the files in a certain folder and have it print out the names of those files.
I have set up a code that opens the files but I cannot get it to print the name. I have a separate code that will print the name but will only open one file. I'm failing at combining the two together correctly. Any ideas?
Code that opens all Excel files:
‘set path to progress folder
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
MyFolder = “C:\Users\trembos\Documents\TDS\progress"
MyFile = Dir(MyFolder & "\*.xlsx")
Do While MyFile <> ""
Workbooks.Open fileName:=MyFolder & "\" & MyFile
MyFile = Dir
Loop
End Sub
Code that prints one file name:
'set path to TDS_Working
Sub TDS()
Workbooks.Open ("C:\Users\trembos\Documents\TDS\progress")
End Sub
'set up dim
Sub LoopThroughDirectory()
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("C:\Users\trembos\Documents\TDS\progress\")
i = 1
'loop through directory file and print names
For Each objFile In objFolder.Files
'print file name
Cells(i + 1, 1) = objFile.Name
Next objFile
End Sub
This should work smoothly :
Sub LoopThroughDirectory()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyFolder As String
Dim Sht As Worksheet
Dim i As Integer
MyFolder = "C:\Users\trembos\Documents\TDS\progress\"
Set Sht = ActiveSheet
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
Set objFolder = objFSO.GetFolder(MyFolder)
i = 1
'loop through directory file and print names
For Each objFile In objFolder.Files
If LCase(Right(objFile.Name, 3)) <> "xls" And LCase(Left(Right(objFile.Name, 4), 3)) <> "xls" Then
Else
'print file name
Sht.Cells(i + 1, 1) = objFile.Name
i = i + 1
Workbooks.Open Filename:=MyFolder & objFile.Name
End If
Next objFile
End Sub
You just need to iterate i inside the loop: i=i+1.
‘set path to progress folder
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
ActiveSheet.Unprotect ("password")
MyFolder = “C:\Users\trembos\Documents\TDS\progress"
MyFile = Dir(MyFolder & "\*.xlsx")
i=1
Do While MyFile <> ""
Workbooks.Open fileName:=MyFolder & "\" & MyFile
MyFile = Dir
Cells(i + 1, 1) =Myfile
i=i+1
Loop
ActiveSheet.Protect ("password")
End Sub
Does this not work?
I currently have this code which will take files from a folder, open each one, print its name into the first column of my "Master file" close it and loop through the entire folder that way.
In each file that is opened, there is information in cell J1 that I would like to copy and paste into column 3 of my "master file". The code works but will only paste the desired info from J1 into C2 over and over so the information keeps being written over. I need to increment down the list so the info from J1 is printed into the same row as the name of the file.
Any ideas?
Sub LoopThroughDirectory()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyFolder As String
Dim Sht As Worksheet
Dim i As Integer
MyFolder = "C:\Users\trembos\Documents\TDS\progress\"
Set Sht = ActiveSheet
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
Set objFolder = objFSO.GetFolder(MyFolder)
i = 1
'loop through directory file and print names
For Each objFile In objFolder.Files
If LCase(Right(objFile.Name, 3)) <> "xls" And LCase(Left(Right(objFile.Name, 4), 3)) <> "xls" Then
Else
'print file name
Sht.Cells(i + 1, 1) = objFile.Name
i = i + 1
Workbooks.Open fileName:=MyFolder & objFile.Name
End If
'Get TDS name of open file
Dim NewWorkbook As Workbook
Set NewWorkbook = Workbooks.Open(fileName:=MyFolder & objFile.Name)
Range("J1").Select
Selection.Copy
Windows("masterfile.xlsm").Activate
'
'
' BELOW COMMENT NEEDS TO BE CHANGED TO INCREMENTING VALUES
Range("D2").Select
ActiveSheet.Paste
NewWorkbook.Close
Next objFile
End Sub
I do some modification on your code and it shows the result that needed by you. Please take note that your macro may spoil if your folder got other extension of files. You may increase the performance of this macro by using the following code : Application.ScreenUpdating = False
Option Explicit
Dim MyMasterWorkbook As Workbook
Dim MyDataWorkbook As Workbook
Dim MyMasterWorksheet As Worksheet
Dim MyDataWorksheet As Worksheet
Sub LoopThroughDirectory()
Set MyMasterWorkbook = Workbooks(ActiveWorkbook.Name)
Set MyMasterWorksheet = MyMasterWorkbook.ActiveSheet
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyDataFolder As String
Dim MyFilePointer As Byte
MyDataFolder = "C:\Users\lengkgan\Desktop\Testing\"
MyFilePointer = 1
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the data folder object
Set objFolder = objFSO.GetFolder(MyDataFolder)
'loop through directory file and print names
For Each objFile In objFolder.Files
If LCase(Right(objFile.Name, 3)) <> "xls" And LCase(Left(Right(objFile.Name, 4), 3)) <> "xls" Then
Else
'print file name
MyMasterWorksheet.Cells(MyFilePointer + 1, 1) = objFile.Name
MyFilePointer = MyFilePointer + 1
Workbooks.Open Filename:=MyDataFolder & objFile.Name
End If
'Get TDS name of open file
Set MyDataWorkbook = Workbooks.Open(Filename:=MyDataFolder & objFile.Name)
Set MyDataWorksheet = MyDataWorkbook.ActiveSheet
'Get the value of J1
MyMasterWorksheet.Range("C" & MyFilePointer).Value = MyDataWorksheet.Range("J1").Value
'close the workbook without saving it
MyDataWorkbook.Close (False)
Next objFile
End Sub
IF the sheetname is consistent across the files ie "Sheet1", you can do this without opening the files:
Sub LoopThroughDirectory()
Dim objFSO As Object, objFolder As Object, objFile As Object, MyFolder As String, Sht As Worksheet
MyFolder = "C:\Users\trembos\Documents\TDS\progress\"
Set Sht = ActiveSheet
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
Set objFolder = objFSO.GetFolder(MyFolder)
'loop through directory file and print names
For Each objFile In objFolder.Files
If Not LCase(Right(objFile.Name, 3)) <> "xls" And Not LCase(Left(Right(objFile.Name, 4), 3)) <> "xls" Then
'print file name
Sht.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Formula = objFile.Name
Sht.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Formula = ExecuteExcel4Macro("'" & MyFolder & objFile.Name & "Sheet1'!R1C10") 'This reads from a closed file
End If
Next objFile
End Sub
This is the solution that works:
'print J1 values to Column 4 of masterfile
With WB
For Each ws In .Worksheets
StartSht.Cells(i + 1, 1) = objFile.Name
With ws
.Range("J1").Copy StartSht.Cells(i + 1, 4)
End With
i = i + 1
'move to next file
Next ws
'close, do not save any changes to the opened files
.Close SaveChanges:=False
End With
Can someone help me with VBA code to rename the subfolder with the part of file name as given below
Folder : C:\Test
Sub folders : C:\Test\a , C:\Test\b , C:\Test\a .... Goes on
It has some file contents and I have to match a file with name starting with VDX_000674 and get last 4 characters and rename the Folder with that.
I have tried the below code but with no use any edits will be appreciated
Sub Rename()
Call Test_Rename("C:\Users\shanmso\Desktop\VN\Output")
End Sub
Sub Test_Rename(MyPath As String)
Dim FileSys As FileSystemObject
Dim objFolder As Folder
Dim objSubFolder As Folder
Dim objFile As File
Dim Riname As String
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set objFolder = FileSys.GetFolder(MyPath)
For Each objFile In objFolder.Files
If Left(objFile.Name, 15) = "DEX-VH_00000374" Then
Riname = Mid(objFile.Name, 17, 3)
Name objFolder As Riname
Exit For
End If
Next objFile
For Each objSubFolder In objFolder.SubFolders
Test_Rename MyPath & "\" & objSubFolder.Name
Next objSubFolder
Set FileSys = Nothing
Set objFolder = Nothing
Set objSubFolder = Nothing
Set objFile = Nothing
End Sub
untested. but I think FreeMan is right Name objFolder As Riname should be something more like this Call MkDir(MyPath & "\" & Riname)
Also I don't think you need the second For Each loop so I removed it. I'm guessing you thought this was actually creating the subfolders, but it isn't. Its easier to just rename the folders in the first For each loop
Sub Test_Rename(MyPath As String)
Dim FileSys As FileSystemObject
Dim objFolder As Folder
Dim objSubFolder As Folder
Dim objFile As File
Dim Riname As String
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set objFolder = FileSys.GetFolder(MyPath)
For Each objFile In objFolder.Files
If Left(objFile.Name, 15) = "DEX-VH_00000374" Then
Riname = Mid(objFile.Name, 17, 3)
Call MkDir(MyPath & "\" & Riname)
Exit For
End If
Next objFile
Set FileSys = Nothing
Set objFolder = Nothing
Set objSubFolder = Nothing
Set objFile = Nothing
End Sub