I am pulling the file names from a folder into my workbook using this
Sub C_Get_file_names_from_TGRE_M1()
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.getfolder("C:\Users\ferna\Downloads\")
For Each oFile In oFolder.Files
Cells(i + 1, 1) = oFile.Name
i = i + 1
Next oFile
End Sub
Now instead of referencing the folder directly I want to write the folder path in a cell like D5 and reference that cell in my code. How could I do that?
Simply replace the hardcoded file path with a range reference to your cell
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Set oFolder = oFSO.getfolder(ws.Range("D5").Value)
Related
This code saves the attachment from Outlook to a specific folder in my PC.
I need to move the selected mail in Outlook inbox to a folder in Outlook.
Ultimately, I will save the attachment and move this mail to a folder in Outlook.
Sub INC_Data()
Dim ol As Object 'Outlook.Application
Dim ns As Object 'Outlook.Namespace
Dim fol As Object 'Outlook.Folder
Dim i As Object
Dim mi As Object 'Outlook.MailItem
Dim at As Object 'Outlook.Attachment
Dim fso As Object 'Scripting.FileSystemObject
Dim dir As Object 'Scripting.Folder
Dim dirName As String
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim f As Integer
'Some Set Ups
Set fso = CreateObject(Class:="Scripting.FileSystemObject")
Set ol = CreateObject(Class:="Outlook.Application")
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)
'Finding the search item from Oulook Inbox
For Each i In fol.Items
If i.Class = 43 Then
Set mi = i
If mi.Attachments.Count > 0 And InStr(mi.SenderEmailAddress, "xxxxxxx#inc.ae") Then
dirName = "D:\XYZ "
If fso.FolderExists(dirName) Then
Set dir = fso.GetFolder(dirName)
Else
Set dir = fso.Createfolder(dirName)
End If
'Saving Attachment to a folder
For Each at In mi.Attachments
If Right(at.Filename, 4) = "xlsm" Then
at.SaveAsFile dir.Path & "\" & Range("Ad2").Text & ".xlsm"
End If
Next at
End If
End If
Next i
End Sub
First, delcare an object variable so that we can assign it the destination folder...
Dim olMoveToFolder As Object 'Outlook.Folder
Then, assign the destination folder to the variable. So, for example, depending on your folder structure, something like this...
Set olMoveToFolder = ns.Folders("Outlook").Folders("DestinationFolderName")
or
Set olMoveToFolder = fol.Folders("DestinationFolderName")
Then, add the following line, after saving the attachments, to move your email to the destination folder...
mi.Move olMoveToFolder
EDIT
While I haven't tested it, I have amended your macro to include the following...
The statement Option Explicit has been added to force the explicit
declaration of variables to help catch any potential errors. Note that
this statement must be place at the very top of the
module, before any procedure.
Some of the variable names have been renamed in the interest of
clarity.
The variable dir has been removed since it's not really needed,
and since it can be confused with the function Dir().
The variable dirName is set prior to looping through your mail
items.
The constant olFolderInbox has been replaced with the value 6,
since you are using late binding.
Here's your macro, amended accordingly...
Option Explicit
Sub INC_Data()
Dim ol As Object 'Outlook.Application
Dim ns As Object 'Outlook.Namespace
Dim inboxFol As Object 'Outlook.Folder
Dim moveToFolder As Object 'Outlook.Folder
Dim itm As Object
Dim mi As Object 'Outlook.MailItem
Dim att As Object 'Outlook.Attachment
Dim fso As Object 'Scripting.FileSystemObject
Dim dirName As String
'Some Set Ups
Set fso = CreateObject(Class:="Scripting.FileSystemObject")
Set ol = CreateObject(Class:="Outlook.Application")
Set ns = ol.GetNamespace("MAPI")
Set inboxFol = ns.GetDefaultFolder(6) 'olFolderInbox
Set moveToFolder = ns.Folders("MainFolderName").Folders("MoveToFolderName") 'change the folder names accordingly
dirName = "D:\XYZ"
If Not fso.FolderExists(dirName) Then
fso.CreateFolder dirName
End If
'Finding the search item from Oulook Inbox
For Each itm In inboxFol.Items
If itm.Class = 43 Then
Set mi = itm
If mi.Attachments.Count > 0 And InStr(mi.SenderEmailAddress, "xxxxxxx#inc.ae") Then
'Saving Attachments to a folder
For Each att In mi.Attachments
If Right(att.Filename, 4) = "xlsm" Then
att.SaveAsFile dirName & "\" & Range("Ad2").Text & ".xlsm"
End If
Next att
'Move mail item to destination folder
mi.Move moveToFolder
End If
End If
Next itm
End Sub
I am trying to achieve the following using a VBA macro:
I have multiple .xls files, all of which have just one sheet
In my macro, I want to append all the data from the other files into one sheet, by appending them at the bottom of the document behind each other. I have figured out the iterating through files, but copying and appending data is what is bugging me.
The code I have until now is as follows (missing parts are described within the comments)
Sub Iterate_Files()
Dim Fso As Object, objFolder As Object, objSubFolder As Object
Dim FromPath As String
Dim FileInFolder As Object
FromPath = ActiveWorkbook.Path
Set Fso = CreateObject("Scripting.filesystemobject")
Set objFolder = Fso.GetFolder(FromPath)
For Each objSubFolder In objFolder.subfolders
For Each FileInFolder In objSubFolder.Files
'Copy the data from sheet one of the FileInFolder
'to the end of sheet in this file :/
Next FileInFolder
Next objSubFolder
End Sub
The following code appears to have solved the problem:
Sub Iterate_Files()
Dim Fso As Object, objFolder As Object, objSubFolder As Object
Dim FromPath As String
Dim FileInFolder As Object
FromPath = ActiveWorkbook.Path
Set Fso = CreateObject("Scripting.filesystemobject")
Set objFolder = Fso.GetFolder(FromPath)
Set TargetWb = ActiveWorkbook
R = 0
For Each objSubFolder In objFolder.subfolders
For Each FileInFolder In objSubFolder.Files
Set wbSource = Workbooks.Open(FileInFolder)
wbSource.Worksheets(1).UsedRange.Copy Destination:=TargetWb.Worksheets(2).Cells(R + 1, 1)
R = R + 15
wbSource.Close SaveChanges:=False
Next FileInFolder
Next objSubFolder
End Sub
Private Sub Rokaj_Click()
Iterate_Files
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 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
I see this issue has come up a handful of times on this forum however none of the solutions have helped me. The code below actually did work, but then it started throwing an application-defined or objected defined error and now will not work. The code runs from within an Excel template, opens up each Excel report in the directory, then pastes 2 worksheets into the document.
Sub updateED()
Dim pathout, pathin As String
Dim WbOutput As Workbook
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(filepath)
'step through each xls file
For Each objFile In objFolder.Files
If InStr(objFile, ".xls") Then
Set WbOutput = Workbooks.Open(objFile)
Application.DisplayAlerts = False
'drop in additional templates
ThisWorkbook.Sheets(Array("Business Entity", "Facility")).Copy before:=WbOutput.Sheets("Mbr_Detail_ED")
End If
Next
End Sub
See if this helps
Option Explicit
Sub updateED()
Dim Pathout As String
Dim Pathin As String
Dim WbOutput As Workbook
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\Temp\")
'step through each xls file
For Each objFile In objFolder.Files
If InStr(objFile, ".xls") Then
Set WbOutput = Workbooks.Open(objFile)
Application.DisplayAlerts = False
'drop in additional templates
ThisWorkbook.Sheets(Array("Business Entity", "Facility")).Copy before:=WbOutput.Sheets("Mbr_Detail_ED")
End If
Next
End Sub