This Excel VBA code creates hyperlinks to a list of items in Column A, to corresponding folder names from a FIXED location. For example:
Room101 is hyperlinked to C:\Files\Pictures\Room101
Room102 is hyperlinked to C:\Files\Pictures\Room102
Room103 is hyperlinked to C:\Files\Pictures\Room103
I have been trying to redesign the folder destination to be more dynamic, specifically the search folder should be the Excel file's current folder. Please see the code below on line 7:
Option Explicit
Dim lngRow
Public Sub Aufruf()
Dim lngTMP As Long
lngTMP = ActiveSheet.Cells(Cells(Rows.Count, "A").End(xlUp).Row, 1).Row
For lngRow = 1 To lngTMP
searchDir "M:\Pictures" 'fixed folder location
Next lngRow
End Sub
Private Sub searchDir(strDir)
Dim objSubDir As Object
Dim strName As String
Dim objFSO As Object
Dim objDir As Object
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objDir = objFSO.getfolder(strDir)
For Each objSubDir In objDir.subfolders
strName = StrReverse(Split(StrReverse(objSubDir.Path), "\")(0))
If strName = Cells(lngRow, 1).Text Then
ActiveSheet.Hyperlinks.Add Anchor:=Cells(lngRow, 1), Address:= _
objSubDir.Path & "\", TextToDisplay:=Cells(lngRow, 1).Text
Exit Sub
End If
searchDir objSubDir
Next
Set objFSO = Nothing
Set objDir = Nothing
End Sub
You will notice that the file path is fixed to "M:\Pictures".
How do I search the folder the Excel document is saved in? I have attempted to use variations of:
path = ActiveWorkbook.Path
Related
I am trying to copy a specific range of data from SAME tab d. Rate Card in 3 different worksheets named "RCR Schedule C - Rate Card.xls" in one folder and paste in master file named "RFP consolidation macro".
I created the loop and am able to copy/paste from the 1st file in the folder but not the other 2. Below is the code for that. Is there any way to ensure the code works for all the files in the folder and not only the first one?
Private Sub CommandButton2_Click()
Dim MyFile As String
Dim erow
MyFile = Dir("c:\Users\s4043091\Desktop\New folder\RFP\NEW\")
Do While Len(MyFile) > 0
If MyFile = "RFP consolidation macro.xlsm" Then
Exit Sub
End If
'Workbooks.Open ("c:\Users\s4043091\Desktop\New folder\RFP\NEW\RCR Schedule C - Rate Card.xls")
Workbooks("RCR Schedule C - Rate Card.xls").Worksheets("d. Rate Card").Range("b3:ah482").Copy _
Workbooks("RFP consolidation macro.xlsm").Worksheets("Masterfile-Rate Card").Range("b1")
Workbooks("RCR Schedule C - Rate Card.xls").Worksheets("a. Company Background").Range("e7").Copy _
Workbooks("RFP consolidation macro.xlsm").Worksheets("Masterfile-Rate Card").Range("a4:a482")
'Range("A2:D200").Copy
'ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, "a").End(xlUp).Offset(1, 0).Row
'ActiveSheet.Paste Destination:=Worksheets("Macro").Range(Cells(erow, 1), Cells(erow, 1))
MyFile = Dir
Loop
End Sub
Not tested, but this should get you going:
Option Explicit
Public Sub LoopFilesInFolderEarlyFSO()
'Early Bound - requires Reference to Microsoft Scripting Runtime; with the reference there is Intellisense
'the Early Bound part:
Dim FSO As FileSystemObject
Set FSO = New FileSystemObject
'Everything after is the same:
Dim myFolderPath As String
myFolderPath = "C:\thePath"
If FSO.FolderExists(myFolderPath) Then
Dim myFolder As Folder
Set myFolder = FSO.GetFolder(myfoderpath)
Else
GoTo ExitSub
End If
Dim currFile As File
For Each currFile In myFolder.Files
Debug.Print currFile.Name
Next
ExitSub:
End Sub
Public Sub LoopFilesInFolderLateFSO()
'Late Bound - requires Creating the FSO; without the reference there is no Intellisense
'the Late Bound part:
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Everything after is the same:
Dim myFolderPath As String
myFolderPath = "C:\thePath"
If FSO.FolderExists(myFolderPath) Then
Dim myFolder As Folder
Set myFolder = FSO.GetFolder(myfoderpath)
Else
GoTo ExitSub
End If
Dim currFile As File
For Each currFile In myFolder.Files
Debug.Print currFile.Name
Next
ExitSub:
End Sub
I've tried and search through out vba forum to figure out how can I rectify my code (below) to search files within a specific directory and its sub-directories to list and populated list of file that have 20 characters in filename length and just only pdf extension.
I want to list of file with no extension at the end in column A and full file path and name in column B.
Also tried to sort all files ascending after list created but no success yet :(
any help? Thanks
Sub ListPDF()
Range("A:L").ClearContents
Range("A1").Select
Dim strPath As String
strPath = "K:\Test\PDF\"
Dim OBJ As Object, Folder As Object, File As Object
Set OBJ = CreateObject("Scripting.FileSystemObject")
Set Folder = OBJ.GetFolder(strPath)
Call ListFiles(Folder)
Dim SubFolder As Object
For Each SubFolder In Folder.Subfolders
Call ListFiles(SubFolder)
Call GetSubFolders(SubFolder)
Next SubFolder
Range("A1").Select
End Sub
Sub ListFiles(ByRef Folder As Object)
For Each File In Folder.Files
ActiveCell.Offset(1, 0).Select
ActiveCell.Offset(0, 0) = File.Name
ActiveCell.Offset(0, 1) = File.Path
Next File
End Sub
Sub GetSubFolders(ByRef SubFolder As Object)
Dim FolderItem As Object
For Each FolderItem In SubFolder.Subfolders
Call ListFiles(FolderItem)
Call GetSubFolders(FolderItem)
Next FolderItem
End Sub
Use this:
Option Explicit
Dim fso As Object, fsoFolder As Object, fsoSubFolder As Object, fsoFile As Object
Public Sub ListPDFs()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
ws.UsedRange.ClearContents
Set fso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False
ShowPDFs ThisWorkbook.Path & "\..", ws
ws.UsedRange.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Public Sub ShowPDFs(ByRef fsoPath As String, ByRef ws As Worksheet)
Dim lastCell As Range, pdfName As String
Set fsoFolder = fso.GetFolder(fsoPath)
For Each fsoFile In fsoFolder.Files
pdfName = fsoFile.Name
If Len(pdfName) > 20 Then
If InStr(1, pdfName, ".pdf") > 0 Then
pdfName = Left(pdfName, InStrRev(pdfName, ".") - 1)
Set lastCell = ws.Cells(ws.Rows.Count, 1).End(xlUp)
lastCell.Offset(1, 0) = pdfName
lastCell.Offset(1, 1) = fsoFile.Path
End If
End If
Next
For Each fsoSubFolder In fsoFolder.SubFolders
ShowPDFs fsoSubFolder.Path, ws
Next
End Sub
Please help with the code for copying files one by one to the destination folder. I tried with "for Each loop but it is copying all the files at once to the destination folder. I am new to to vba and would be helpful if someone could crack the code for me. thanks in advance. here's the code i have managed to come up with.
I am getting run time error 53, File not found,e highlighting the below syntax.
FSO.movefile Source:="C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro\" & Fname, Destination:="C:\Users\wazeer.ahamed\Documents\TcktIDfolder\" & Fname
Sub Example1()
'Extracting file names Dim objFSO As Object Dim objFolder As Object Dim newobjFile As Object
Dim lastID As Long Dim myRRange As Range Dim Maxvalue As Integer
Dim sFolder As String Dim dFolder As String
Sub Example1()
'Extracting file names
Dim FSO
Dim objFolder As Object
Dim newobjFile As Object
Dim FromDir As String
Dim ToDir As String
Dim lastID As Long
Dim myRRange As Range
Dim Maxvalue As Integer
Dim Fname As String
FromDir = "C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro\"
ToDir = "C:\Users\wazeer.ahamed\Documents\TcktIDfolder\"
Fname = Dir(FromDir)
If Len(FromDir) = 0 Then
MsgBox "No files"
Exit Sub
End If
Set myRange = Worksheets("Sheet1").Range("C:C")
Maxvalue = Application.WorksheetFunction.Max(myRange)
lastID = Maxvalue
'finding the next availabe row
erow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'Extracting file names
'Create an instance of the FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = FSO.GetFolder("C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro")
'loops through each file in the directory and prints their names and path
For Each newobjFile In objFolder.Files
'print file name
Cells(erow, 1) = Fname
'print file path
Cells(erow, 2) = newobjFile.Path
'PrintUniqueID
Cells(erow, 3) = lastID + 1
FSO.movefile Source:="C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro\" & Fname, Destination:="C:\Users\wazeer.ahamed\Documents\TcktIDfolder\" & Fname
Cells(erow, 5) = "file succesfully copied"
Next newobjFile
Set FSO = Nothing
Set newobjFile = Nothing
Set objFolder = Nothing
End Sub
I think that the code can be more simple and dynamic if you play with your own excel file.
Use "A1" range to put the source folder.
Use "B:B" range to put the
name of the files.
Use "C:C" range to concatenate the previous
columns.
Use "D1" range to put the destination folder.
Sub copyFiles()
'Macro for copy files
'Set variable
Dim source As String
Dim destination As String
Dim x As Integer
Dim destinationNumber As Integer
destinationNumber = WorksheetFunction.CountA(ThisWorkbook.Sheets("Sheet1").Range("C:C"))
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Create the folder if not exist
If Dir(ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Sheet1").Range("D1"), 16) = "" Then
MkDir ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Sheet1").Range("D1")
End If
'Run the loop to copy all the files
For x = 1 To destinationNumber
source = ThisWorkbook.Sheets("Sheet1").Range("C" & x)
destination = ThisWorkbook.Sheets("Sheet1").Range("D1")
FileCopy source, destination
Next x
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
With this you can change the folders' paths and file names whenever you want. I've used FileCopy to preserve your files in the source but if you need to delete it's better use other method.
I am looking in the Folder for specific file in .docx and want to open it. I put the Name of X into Inputbox, go to Sheet Y, look on the next right cell of X and open this as Word (next cell right is an file in word I want to open). It is working, but the Problem is that the target Word Doc may be in multiples subfolders. Is there any quick way to search in These subfolder?
Private Sub CommandButton1_Click()
On Error GoTo ErrorHandling
Application.ScreenUpdating = False
Dim AppWD As Object
Dim SearchX As String
Dim SearchArea As Range
Dim Y As String
Dim sPath As String
sPath = "C:\Users\VS\Desktop\test"
SearchRule = InputBox("X")
Set SearchArea = Sheets("Look").Range("A:A").Find(what:=SearchX, _
LookIn:=xlFormulas, lookat:=xlWhole)
ActiveWindow.Visible = True
Target = SearchArea.Offset(0, 1).Value
Set AppWD = CreateObject("Word.Application")
AppWD.Visible = True
AppWD.documents.Open (sPath & "\" & Target & "." & "docx")
ErrorHandling: Exit Sub
End Sub
My take on searching throught subfolders
Sub searchSub()
Dim fso As FileSystemObject, fFile As File, fFolder As Folder
Dim fSubFolder As Folder, fPath As String, FileToSearch As String
Set fso = New FileSystemObject
FileToSearch = "SomeDocument.docx"
fPath = ThisWorkbook.Path
Set fFolder = fso.GetFolder(fPath)
For Each fFolder In fFolder.SubFolders
Set fSubFolder = fso.GetFolder(fFolder.Path)
For Each fFile In fSubFolder.Files
If fFile.Name = FileToSearch Then
'do something with file
End If
Next fFile
Next fFolder
End Sub
I have a two codes. I would like the second code to perform the first code on all files in a directory. The first code works like a charm and does exactly what I need it to, this is that:
Sub STATTRANSFER()
' Transfers all STATS lines
Application.ScreenUpdating = False
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "STATS"
Set f = Sheets(1)
Set e = Sheets("Stats")
Dim d
Dim j
Dim k
d = 1
j = 1
k = 1
Do Until IsEmpty(f.Range("A" & j))
If f.Range("A" & j) = "STATS" Then
e.Rows(d).Value = f.Rows(j).Value
d = d + 1
f.Rows(j).Delete
Else
j = j + 1
End If
Loop
Application.ScreenUpdating = True
End Sub
The second code looks like this:
Public Sub DataProcess()
Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String
Set OrigWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path
Set mainFolder = objFSO.GetFolder(folderPath)
filename = Dir(folderPath & "*.csv")
Do While Len(filename) > 0
Set WB = Workbooks.Open(folderPath & filename)
Call STATTRANSFER
ActiveWorkbook.Close SaveChanges:=True
filename = Dir
Loop
For Each mySubFolder In mainFolder.SubFolders
filename = Dir(mySubFolder.Path & "\*.csv*")
Do While Len(filename) > 0
Set WB = Workbooks.Open(mySubFolder.Path & "\" & filename)
Call STATTRANSFER
ActiveWorkbook.Close SaveChanges:=True
filename = Dir
Loop
Next
End Sub
The second code does successfully loop through all of the folders and documents I want it to, however it performs my first code incorrectly. When I perform the first code on a sheet alone, it creates a new sheet called STATS then takes all lines from the first sheet that has the word STATS in column A and copies them to the new sheet, it then deletes the STATS lines out of the first sheet.
When I run it with the second code that goes through all the folders it doesn't work the same. I can see it create the sheet called STATS on my screen but then when it finishes and I open up on of the documents all the lines that have STATS in column A are on the first sheet, the STATS sheet is no longer there, and all the data that didn't have STATS in column A is gone. So I'm not sure what the problem is.
Keep your first sub as it is, replace your second sub with this:
Sub MM()
Dim file As Variant
Dim files As Variant
Dim WB As Excel.Workbook
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
Set WB = Workbooks.Open(file)
STATTRANSFER
WB.Close True
Set WB = Nothing
Next
End Sub
just as an remark: your code only runs thru the first level of sub folders. If you want to go thru all sub level folders, you have to use a recursive method like:
Private Sub test()
readFileSystem ("C:\Temp\")
End Sub
Private Sub readFileSystem(ByVal pFolder As String)
Dim oFSO As Object
Dim oFolder As Object
' create FSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
' get start folder
Set oFolder = oFSO.getFolder(pFolder)
' list folder content
listFolderContent oFolder
' destroy FSO
Set oFolder = Nothing
Set oFSO = Nothing
End Sub
Private Sub listFolderContent(ByVal pFolder As Object)
Dim oFile As Object
Dim oFolder As Object
' go thru all sub folders
For Each oFolder In pFolder.SubFolders
Debug.Print oFolder.Path
' do the recursion to list sub folder content
listFolderContent oFolder
Next
' list all files in that directory
For Each oFile In pFolder.Files
Debug.Print oFile.Path
Next
' destroy all objects
Set pFolder = Nothing
Set oFile = Nothing
Set oFolder = Nothing
End Sub
this is just an example and you have to call your first procedure of course still correct. So I would suggest to add a parameter to the first procedure where you can pass the workbook.
and BTW: always delcare your variables with datatype. Dim j will declare a VARIANT variable and not a Interger as you might want to have.
You see all STATS in the first sheet because you added an extra sheet to a CSV file and saved it. By definition, CSV file only saves and shows 1 sheet.
This modification to your code could solve your problem, as it calls itself to go through subfolders.
Try it.
Include your STATTRANSFER sub.
Public Sub DataProcess()
thisPath = ThisWorkbook.Path
process_folders (thisPath)
End Sub
Sub process_folders(thisPath)
Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String
Set OrigWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path
Set mainFolder = objFSO.GetFolder(folderPath)
folderPath = ActiveWorkbook.Path
filename = Dir(folderPath & "\*.csv")
Do While Len(filename) > 0
Set WB = Workbooks.Open(folderPath & "\" & filename)
Call STATTRANSFER
'save file as Excel file !!!
ActiveWorkbook.SaveAs _
filename:=(folderPath & "\" & filename), _
FileFormat:=xlOpenXMLWorkbook, _
CreateBackup:=False
ActiveWorkbook.Close (False)
filename = Dir
Loop
'now with each subfolder
For Each subfolder In mainFolder.SubFolders
process_folders (subfolder)
Next
End Sub
The problem was that you can only save a .csv with one sheet on it. Now the code looks like this.
Sub NewDataProcess()
Dim file As Variant
Dim files As Variant
Dim wb As Excel.Workbook
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
Set wb = Workbooks.Open(file)
Call STATTRANSFER(wb)
newfilename = Replace(file, ".csv", ".xlsm")
wb.SaveAs filename:=newfilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
wb.Close SaveChanges:=False
Set wb = Nothing
Next
End Sub
Now I need a way to delete the old files if someone can help with that. I dont want the CSV file at all anymore