loop through folders vba - excel

Sub CheckandSend()
Dim strfile As String
Dim ws As Worksheet 'make sure to define a sheet
Set ws = ThisWorkbook.Worksheets("RFQ")
Sheets("RFQ").Select
Dim Sourcepath As String
Sourcepath = "P:\CENTRAL PLANNING\PROJECTS 2020-2021\VALEO FRANCE 35101380FM\Drg folder\"
Dim destpath As String
destpath = "P:\CENTRAL PLANNING\PROJECTS 2020-2021\VALEO FRANCE 35101380FM\New folder1\"
'make sure paths end with \
Dim irow As Long
Dim f As SearchFolders
Dim filetype As String
filetype = "*.pdf"
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 & FileName, destpath & FileName
'copy needs to be path AND filename
FileName = Dir()
Loop
irow = irow + 1
Loop
Sheets("RFQ").Select
Columns("AB:AG").Select
Selection.Delete
End Sub
on here , this code is help me to find a pdf file which matches my excel cell data and after that finding a file it will copy that particular file and paste in the destination folder
my issue is my file name in excel will look like
AVRO15VE1522A,
AVRO15VE1523B,
AVRO15VE1524C , (In the file name list, the last alphabet is revision it may change as A,B,C,D,E.....Z)
but in my folder the file name will be like
AVRO15VE1522 A, (OR) AVRO15VE1522A,
AVRO15VE1523 B, (OR) AVRO15VE1523B,
sometimes multiple files with same file name will present ,so i want only one file on that particular file name
and if all the revision files which is
AVRO15VE1522A,
AVRO15VE1522B,
AVRO15VE1522C,
Is present in folder means , i want the code to take a file which matches my filename in excel range

Related

Copy PDF from source folder to destination folder

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.

copy file from excel list with extension to other folder

I am new in VBA, so I have a list of document (with extension .pdf, .docx, etc) in excel column. What I would like to do is to copy all document in the list, from source folder to destination folder.
I already tried some code, it works but the code copy all the files in the folder instead of the file in list (The document list is only in B3:B10).
Any help really appreciated.
Thanks in advance.
Sub copyfile()
Dim r As Range
Dim Jajal As Range
Dim sourcePath As String, DestPath As String, FName As String
sourcePath = "C:\Users\"
DestPath = "H:\Users\"
For Each r In Range(Sheet6.Range("B3"), Sheet6.Range("B10")) 'the list document is in the sheet6 B3:B10
FName = Dir(sourcePath & r)
'Loop while files found
Do While FName <> ""
'Copy the file
FileCopy sourcePath & FName, DestPath & FName
'Search the next file
FName = Dir()
Loop
Next
End Sub
Copy Files From Range (List)
The Code
Option Explicit
' This will copy files found in a source path AND whose names
' are contained in a list (range), to a destination path,
' overwriting possible existing files.
Sub copyFiles()
Const SourcePath As String = "C:\Users\"
Const DestPath As String = "H:\Users\"
Const ListAddress As String = "B3:B10"
' Write file list to array.
Dim FileList As Variant: FileList = Sheet1.Range(ListAddress).Value
' 'Get' first file name.
Dim FName As String: FName = Dir(SourcePath)
' 'Initiate' counter.
Dim i As Long
' Loop files in SourcePath.
Do While FName <> ""
' Check if file name of current file is contained in array (FileList).
If Not IsError(Application.Match(FName, FileList, 0)) Then
' Count file.
i = i + 1
' Copy file.
FileCopy SourcePath & FName, DestPath & FName
End If
' 'Get' next file name.
FName = Dir()
Loop
' Inform user.
Select Case i
Case 0: MsgBox "No files found", vbExclamation, "No Files"
Case 1: MsgBox "Copied 1 file.", vbInformation, "Success"
Case Else: MsgBox "Copied " & i & " files.", vbInformation, "Success"
End Select
End Sub
Using Dir you loop over all the files in the directory. If you know your files, you don't need Dir. Try like the following (not tested):
Sub copyfile()
Dim r As Range
Dim Jajal As Range
Dim sourcePath As String, DestPath As String
sourcePath = "C:\Users\"
DestPath = "H:\Users\"
For Each r In Range(Sheet6.Range("B3"), Sheet6.Range("B10")) 'the list document is in the sheet6 B3:B10
'Loop while files found
If r.Value <> ""
'Copy the file
FileCopy sourcePath & r.Value, DestPath & r.Value
'Search the next file
End If
Next
End Sub
However, you could test if the file exists before you copy.

copy file from excel listto other folder

I am new in VBA, so I have a list of document (just file name, without extension .pdf, .docx, etc) in excel column. What I would like to do is to copy all document in the list, from source folder to destination folder.
I already tried some code, it works but the code copy all the files in the folder instead of the file in list (The document list is only in B3:B10).
Any help really appreciated.
Thanks in advance.
Sub copyfile()
Dim r As Range
Dim Jajal As Range
Dim sourcePath As String, DestPath As String, FName As String
sourcePath = "C:\Users\"
DestPath = "H:\Users\"
For Each r In Range(Sheet6.Range("B3"), Sheet6.Range("B10")) 'the list document is in the sheet6 B3:B10
FName = Dir(sourcePath & r)
'Loop while files found
Do While FName <> ""
'Copy the file
FileCopy sourcePath & FName, DestPath & FName
'Search the next file
FName = Dir()
Loop
Next
End Sub
You shouldn't need the Dir method
For Each r In Range(Sheet6.Range("B3"), Sheet6.Range("B10")) 'the list document is in the sheet6 B3:B10
FileCopy sourcePath & r.value, DestPath & r.value
Next

VBA copying all the Excel files in a folder to a single file causes runtime error

I am attempting to use VBA to open all the excel files in a directory (in this case c:\temp) and put all the files datasheets in one large file. Each new sheet is named with the filename plus the name of the sheet on the original document. The code that I have copies the first file's first sheet and even names it correctly, but then fails with a Run-time error 1004: Application defined or object defined error on the second sheet when I try to set the name. Anyone have any suggestions on how to fix.
Sub MergeAllWorkbooks()
Dim FolderPath As String
Dim FileName As String
' Create a new workbook
Set FileWorkbook = Workbooks.Add(xlWBATWorksheet)
' folder path to the files you want to use.
FolderPath = "C:\Temp\"
' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.xl*")
' Loop until Dir returns an empty string.
Do While FileName <> ""
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)
Dim currentSheet As Worksheet
Dim sheetIndex As Integer
sheetIndex = 1
Windows(WorkBk.Name).Activate
For Each currentSheet In WorkBk.Worksheets
currentSheet.Select
currentSheet.Copy Before:=Workbooks(FileWorkbook.Name).Sheets(sheetIndex)
FileWorkbook.Sheets(sheetIndex).Name = FileName & "-" & currentSheet.Name
sheetIndex = sheetIndex + 1
Next currentSheet
' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False
' Use Dir to get the next file name.
FileName = Dir()
Loop
End Sub
Replace
FileWorkbook.Sheets(sheetIndex).Name = FileName & "-" & currentSheet.Name
with (I separated it out for readability)
sWSName = FileName & "-" & currentSheet.Name
sWSName = NameTest(sWSName)
sWSName = TestDup(sWSName)
FileWorkbook.Sheets(sheetIndex).Name = sWSName
You will need to define the sWSName.
Below are the modified functions I have previously used.
Function NameTest(sName As String) As String
NameTest = sName
aSpecChars = Array("\", "/", "*", "[", "]", ":", "?")
For Each c In aSpecChars
NameTest = Replace(NameTest, c, "")
Next c
If Len(sName) > 31 Then NameTest = Left(sName, 31)
End Function
Function TestDup(sWSName As String) As String
TestDup = sWSName
For Each ws In Worksheets
Debug.Print ws.Name
If sWSName = ws.Name Then TestDup = TestDup(Left(sWSName, Len(sWSName) - 1))
Next ws
End Function
If posting this code (or to this extent) is out of line please let me know as I am still coming to terms with the level of effort require versus reasonable response.

Dir() function not working in Mac Excel 2011 VBA

Hi I am trying to list all the files in a subdirectory of where the Excel workbook is residing in. For some reason, the code cannot execute beyond the Dir function. Can anyone please advise? Thank you!
Sub ListFiles()
ActiveSheet.Name = "temp"
Dim MyDir As String
'Declare the variables
Dim strPath As String
Dim strFile As String
Dim r As Long
MyDir = ActiveWorkbook.Path 'current path where workbook is
strPath = MyDir & ":Current:" 'files within "Current" folder subdir, I am using Mac Excel 2011
'Insert the headers in Columns A, B, and C
Cells(1, "A").Value = "FileName"
Cells(1, "B").Value = "Size"
Cells(1, "C").Value = "Date/Time"
'Find the next available row
r = Cells(Rows.Count, "A").End(xlUp).Row + 1
'Get the first file from the folder
'Note: macro stops working here
strFile = Dir(strPath & "*.csv", vbNormal)
'Loop through each file in the folder
Do While Len(strFile) > 0
'List the name, size, and date/time of the current file
Cells(r, 1).Value = strFile
Cells(r, 2).Value = FileLen(strPath & strFile)
Cells(r, 3).Value = FileDateTime(strPath & strFile)
'Determine the next row
r = r + 1
'Get the next file from the folder
strFile = Dir
Loop
'Change the width of the columns to achieve the best fit
Columns.AutoFit
End Sub
Gianna, you cannot use DIR like that in VBA-EXCEL 2011. I mean the wildcards are not supported. You have to use MACID for this purpose.
See this code sample (TRIED AND TESTED)
Sub Sample()
MyDir = ActiveWorkbook.Path
strPath = MyDir & ":"
strFile = Dir(strPath, MacID("TEXT"))
'Loop through each file in the folder
Do While Len(strFile) > 0
If Right(strFile, 3) = "csv" Then
Debug.Print strFile
End If
strFile = Dir
Loop
End Sub
See this link for more details on MACID
Topic: MacID Function
Link: http://office.microsoft.com/en-us/access-help/macid-function-HA001228879.aspx
EDIT:
In case that link ever dies which I doubt, here is an extract.
MacID Function
Used on the Macintosh to convert a 4-character constant to a value that may be used by Dir, Kill, Shell, and AppActivate.
Syntax
MacID(constant)
The required constant argument consists of 4 characters used to specify a resource type, file type, application signature, or Apple Event, for example, TEXT, OBIN, "XLS5" for Excel files ("XLS8" for Excel 97), Microsoft Word uses "W6BN" ("W8BN" for Word 97), and so on.
Remarks
MacID is used with Dir and Kill to specify a Macintosh file type. Since the Macintosh does not support * and ? as wildcards, you can use a four-character constant instead to identify groups of files. For example, the following statement returns TEXT type files from the current folder:
Dir("SomePath", MacID("TEXT"))
MacID is used with Shell and AppActivate to specify an application using the application's unique signature.
HTH
If Dir(outputFileName) <> "" Then
Dim ans
ans = MsgBox("File already exists.Do you wish to continue(the previous file will be deleted)?", vbYesNo)
If ans = vbNo Then
Exit Sub
Else
Kill outputFileName
End If
End If
For listitem = 0 To List6.ListCount() - 1
For the answer above, it worked for me when I took out the "TEXT" in MacID:
Sub LoopThruFiles()
Dim mydir As String
Dim foldercount As Integer
Dim Subjectnum As String
Dim strpath As String
Dim strfile As String
ChDir "HD:Main Folder:"
mydir = "HD:Main Folder:"
SecondaryFolder = "Folder 01:"
strpath = mydir & SecondaryFolder
strfile = Dir(strpath)
'Loop through each file in the folder
Do While Len(strfile) > 0
If Right(strfile, 3) = "cef" Then
MsgBox (strfile)
End If
strfile = Dir
Loop
End Sub

Resources