Could someone tell me if it is possible for a user to input two seperate dates into input boxes and then search a folder for files with (ideally) create dates that fall between the input dates?
I can do a search through files in a folder fine but the number of files is increasing every day and the time to run a search through all of them is getting longer. I'm hopeing that if the user can select a date range then this will cut down the time to run.
If that isn't possible at all is it possible to set a macro to search through files in a folder STARTING with the most recently created and then working back from there?
Sub UKSearch()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Search function to find specific consignment number from multiple intake sheets'
'Used by Traffic Office '
'Created by *********** 11/03/14 Password to unlock = ********* '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim FSO As Object 'FileSystemObject
Set FSO = CreateObject("scripting.filesystemobject")
Dim Directory As String
Dim FileName As String
Dim varCellvalue As Long
Application.ScreenUpdating = False
MsgBox ("This may take a few minutes")
'value to be searched
varCellvalue = Range("D13").Value
'Change the directory below as needed
Directory = "\\*******\shared$\Common\Returns\*********\"
If Right(Directory, 1) <> "\" Then
Directory = Directory & "\"
End If
'Search for all files in the directory with an xls* file type.
FileName = Dir(Directory & "*.xls*")
''''''''''''''''''''''''
'Opens, searches through and closes each file
Do While FileName <> ""
OpenFile = Directory & FileName
Workbooks.Open (OpenFile)
Workbooks(FileName).Activate
'Count through all the rows looking for the required number
ActiveWorkbook.Sheets("UK Scan Sheet").Activate
LastRow = Range("B65536").End(xlUp).Row
intRowCount = LastRow
Range("B1").Select
For i = 1 To intRowCount
'If the required number is found then select it and stop the search
If ActiveCell.Value = varCellvalue Then
GoTo Finish
Else
End If
ActiveCell.Offset(1, 0).Select
Next i
Workbooks(FileName).Close
FileName = Dir
OpenFile = ""
Loop
''''''''''''''''''''''''''
Finish:
Application.ScreenUpdating = False
End Sub
Add to your dim section:
Dim oFile
Before your loop add:
Set oFile = CreateObject("Scripting.FileSystemObject")
In your loop before you open the file add an if statement:
if oFile.getFile(Directory & FileName).DateCreated >= EarliestDate and oFile.getFile(Directory & FileName).DateCreated <= LatestDate
You can also use oFile.getFile(Directory & FileName).DateLastModified - if you want to use the last change date of file instead of creation date.
Related
I want to do it with vba wscript.shell because copying files is faster and I want to copy files based on path or filename in excel cell based on the selection in column "E" and output the destination folder using "msoFileDialogFolderPicker"
I have sample code but need to change.
Sub copy()
xDFileDlg As FileDialog
xDPathStr As Variant
sn = Filter(Split(CreateObject("wscript.shell").exec("cmd /c dir C:\copy\*.* /b /s").stdout.readall, vbCrLf), "\")
'For j = 0 To UBound(sn)
'If DateDiff("d", FileDateTime(sn(j)), Date) > 30 Then sn(j) = ""
'Next
sn = Filter(sn, "\")
For j = 0 To UBound(sn)
FileCopy sn(j), "C:\destcopy" & Mid(sn(j), 2)
Next
Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xDFileDlg.Title = "Please select the destination folder:"
If xDFileDlg.Show <> -1 Then Exit Sub
xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"
End Sub
Thanks
roy
Please, test the next code. It assumes that you need to select the destination folder for copying of all files there. Otherwise, some milliseconds saved by VBScript object mean too little against the necessary seconds to browse for each file destination folder to be copied. But, if this is what you want, I can easily adapt the code to do that:
Sub copyFiles()
Dim sh As Worksheet, lastR As Long, arrA, i As Long, k As Long
Dim fileD As FileDialog, strDestFold As String, FSO As Object
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row ' last row on A:A column
arrA = sh.Range("A2:E" & lastR).Value2 'place the range in an array for faster iteration
Set FSO = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select the destination folder!"
.AllowMultiSelect = False
If .Show = -1 Then
strDestFold = .SelectedItems.Item(1) & "\" 'select the destination folder
End If
End With
If strDestFold = "" Then Exit Sub 'in case of not selecting any folder
For i = 1 To UBound(arrA)
If UCase(arrA(i, 5)) = "V" Then 'copy the file only if a "V" exists in column E:E
If FSO.FileExists(arrA(i, 1)) Then 'check if the path in excel is correct
FSO.CopyFile arrA(i, 1), strDestFold, True 'copy the file (True, to overwrite the file if it exists)
k = k + 1
Else
MsgBox arrA(i, 1) & " file could not be found." & vbCrLf & _
"Please, check the spelling and correct the file full path!", vbInformation, _
"File does not exist..."
End If
End If
Next i
MsgBox "Copied " & k & " files in " & strDestFold, , "Ready..."
End Sub
I wrote a code where I want a user to select multiple files that code will loop through.
I can't get the loop to work as I am not defining the name right.
Sub RFPDataimporttest() 'select multiple files
Dim Files As Workbook
Dim Fname As Variant
Dim SrcWbk As Workbook
Dim DestWbk As Workbook
Dim i As Integer
Set DestWbk = ThisWorkbook
'choose files and define them as array
Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Select alla RFP filer från leverantörer", MultiSelect:=True)
If IsArray(Fname) Then
For i = LBound(Fname) To UBound(Fname)
'this where i have a problem. how do i open each file in an array?
Set SrcWbk = Workbooks.Open(Fname)
SrcWbk.Sheets("1. General Information").Range("L8").Copy
With DestWbk.Worksheets("Sheet1").Cells(2, Columns.Count).End(xlToLeft).Offset(-1, 1)
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteValues
End With
SrcWbk.Sheets("2. Product information").Range("Z1:AB91").Copy
With DestWbk.Worksheets("Sheet1").Cells(2, Columns.Count).End(xlToLeft).Offset(0, 1)
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteValues
End With
SrcWbk.Close False
Next i
End If
End Sub
The result is an array - you are already checking that and looping over it. Simply use i as index:
Set SrcWbk = Workbooks.Open(Fname(i))
(note that the result is even an array when user selects only one file, so code will work for that case also)
I am trying to accomplish a simple task of merging PDF files to one PDF. And I want the resulting PDF file to have Bookmarks to each file from the filename. And preferably i would like to have a free solution for this.
I am on a windows system and want to execute this from either command line or even better from MSSQL.
The thing is that i will create PDF files of orders from an ERP system with Crystal Reports. An stored procedure will create these PDF files. After that i want to take selected PDFs and create a new merged PDF of those and the merged PDF should have each order number (from the filename) as a bookmark. So that you easily can jump to an order number if you are searching for a specific one.
And as I said preferably free solutions, if not available I am ready to code my own merge program in for example C# or similar.
I think you would need Adobe Acrobat for this, at a bare minimum. Or, if you don't have that and you don't want to pay for it, you can convert all PDFs to TXT files, and merge all TXT files. This sounds a bit cumbersome, but actually, the easiest thing to do . . . maybe . . . is to convert all those TXT files into Excel files, and merge those. That shouldn't be hard at all. Here is a script to convert all TXT files into Excel files.
Private Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
Public Function ChDirNet(szPath As String) As Boolean
'based on Rob Bovey's code
Dim lReturn As Long
lReturn = SetCurrentDirectoryA(szPath)
ChDirNet = CBool(lReturn <> 0)
End Function
Sub Get_TXT_Files()
'For Excel 2000 and higher
Dim Fnum As Long
Dim mysheet As Worksheet
Dim basebook As Workbook
Dim TxtFileNames As Variant
Dim QTable As QueryTable
Dim SaveDriveDir As String
Dim ExistFolder As Boolean
'Save the current dir
SaveDriveDir = CurDir
'You can change the start folder if you want for
'GetOpenFilename,you can use a network or local folder.
'For example ChDirNet("C:\your_path_here\")
'It now use Excel's Default File Path
ExistFolder = ChDirNet("C:\your_path_here\\Text\")
If ExistFolder = False Then
MsgBox "Error changing folder"
Exit Sub
End If
TxtFileNames = Application.GetOpenFilename _
(filefilter:="TXT Files (*.txt), *.txt", MultiSelect:=True)
If IsArray(TxtFileNames) Then
On Error GoTo CleanUp
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Add workbook with one sheet
Set basebook = Workbooks.Add(xlWBATWorksheet)
'Loop through the array with txt files
For Fnum = LBound(TxtFileNames) To UBound(TxtFileNames)
'Add a new worksheet for the name of the txt file
Set mysheet = Worksheets.Add(After:=basebook. _
Sheets(basebook.Sheets.Count))
On Error Resume Next
mysheet.Name = Right(TxtFileNames(Fnum), Len(TxtFileNames(Fnum)) - _
InStrRev(TxtFileNames(Fnum), "\", , 1))
On Error GoTo 0
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & TxtFileNames(Fnum), Destination:=Range("A1"))
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
'This example use xlDelimited
'See a example for xlFixedWidth below the macro
.TextFileParseType = xlDelimited
'Set your Delimiter to true
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
'Set the format for each column if you want (Default = General)
'For example Array(1, 9, 1) to skip the second column
.TextFileColumnDataTypes = Array(1, 9, 1)
'xlGeneralFormat General 1
'xlTextFormat Text 2
'xlMDYFormat Month-Day-Year 3
'xlDMYFormat Day-Month-Year 4
'xlYMDFormat Year-Month-Day 5
'xlMYDFormat Month-Year-Day 6
'xlDYMFormat Day-Year-Month 7
'xlYDMFormat Year-Day-Month 8
'xlSkipColumn Skip 9
' Get the data from the txt file
.Refresh BackgroundQuery:=False
End With
ActiveSheet.QueryTables(1).Delete
Next Fnum
'Delete the first sheet of basebook
On Error Resume Next
Application.DisplayAlerts = False
basebook.Worksheets(1).Delete
Application.DisplayAlerts = True
On Error GoTo 0
CleanUp:
ChDirNet SaveDriveDir
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub
I really hope someone can help me with this....
I have a macro at the moment that allows the user to input an 8 digit number and then the code searchs all .xls files in a specific folder until it finds that number. So far there are 61 files to search through and that number is getting bigger every day! My code works fine but it is a slow process and one that the user will be doing many times a day.
Desired outcome - the user will input a date, ie - 2013-10-28, which is the first part of a file name, then input a second date in the same format and then an 8 digit number. The macro will then open a preset folder, find the first file, open it and search for the 8 digit number. If the number is not found i want the macro to move to the next file in the folder until either the number is found or it reaches the second date defined folder at which point it will stop.
Worst case i'd like my existing macro to function the same but start with the most recently modified file and work backwards to cut down the running time.
This is what i have so far (vaCellvalue is the 8 digit number input by the user):-
Sub UKSearch()
Dim FSO As Object 'FileSystemObject
Set FSO = CreateObject("scripting.filesystemobject")
Dim Directory As String
Dim FileName As String
Dim varCellvalue As Long
Application.ScreenUpdating = False
MsgBox ("This may take a few minutes")
'value to be searched
varCellvalue = Range("D13").Value
'Change the directory below as needed
Directory = "\\**********\shared$\******\*******\********\"
If Right(Directory, 1) <> "\" Then
Directory = Directory & "\"
End If
'Search for all files in the directory with an xls* file type.
FileName = Dir(Directory & "*.xls*")
'Opens, searches through and closes each file
Do While FileName <> ""
OpenFile = Directory & FileName
Workbooks.Open (OpenFile)
Workbooks(FileName).Activate
'Count through all the rows looking for the required number
ActiveWorkbook.Sheets("UK Scan Sheet").Activate
LastRow = Range("B65536").End(xlUp).Row
intRowCount = LastRow
Range("B1").Select
For i = 1 To intRowCount
'If the required number is found then select it and stop the search
If ActiveCell.Value = varCellvalue Then
GoTo Finish
Else
End If
ActiveCell.Offset(1, 0).Select
Next i
Workbooks(FileName).Close
FileName = Dir
OpenFile = ""
Loop
Finish:
Application.ScreenUpdating = False
End Sub`
For anyone else out there who might one day ask this question here is the answer that i came up with in the end. Please be aware however as stated in my original question above, the dates involved here are file names - when the input box asks for a file creation date it is really asking the user for the first part of a file name that happens to always be a date.
Sub OpenByCreationDate()
Dim appShell As Object
Dim FileName As Variant
Dim FilePath As Variant
Dim oFolder As Object
Dim oFolderItem As Object
Dim TestDate As Variant
Dim IntCount As Variant
FolderPath = "\\cor-***-****\shared$\Common\Returns\**************\"
FileName = "*.xls*"
EnterDate:
TestDate = inputbox("Enter the file creation date below.")
If Not IsDate(TestDate) Then
MsgBox "The Date you entered is not valid." & vbCrLf _
& "Please enter the date again."
GoTo EnterDate
End If
SearchValue = inputbox("Enter the consignment number below.")
IntCount = 0
Set appShell = CreateObject("Shell.Application")
Set oFolder = appShell.Namespace(FolderPath)
For Each oFolderItem In oFolder.Items
If IntCount > 0 Then
TestDate = Left(oFolderItem.Name, 10)
Else
End If
If oFolderItem.Name Like TestDate & FileName Then
Workbooks.Open oFolderItem.Path
ActiveWorkbook.Sheets("UK Scan Sheet").Activate
LastRow = Range("B65536").End(xlUp).Row
intRowCount = LastRow
Range("B1").Select
For i = 1 To intRowCount
'If the required number is found then select it and stop the search
If ActiveCell.Value = SearchValue Then
ActiveCell.Select
MsgBox "Consignment number found."
GoTo Finish
Else
End If
ActiveCell.Offset(1, 0).Select
Next i
ActiveWorkbook.Close
IntCount = IntCount + 1
If IntCount = 10 Then
MsgBox "Consignment number could not be found, please try a different date."
Exit Sub
Else
End If
End If
Next oFolderItem
Finish:
End Sub
I've got lots of files in a folder structered with names like:
"prof102122013#10.18.41.csv"
where the "02122013" bit is the date - 02/12/2013. Some of them have been made on the same day. I'd like to create a file that takes all of the workbooks that were made on the same day and put them all in one big file. So far I am struggling to get the selectivity to open a day-specific file. Does anyone have any idea what kind of code can help me with this?
Edit: Solved, thanks for the help, all! Here was the code that worked for me:
folder_location = Application.ActiveWorkbook.Path
i2 = 0
strFile = Dir(folder_location & "\")
'looping through to find the right file names and putting them all in an array
While strFile <> ""
If Right(strFile, 3) = "csv" Then
file_to_analyse = Split(strFile, "#")
If Right(file_to_analyse(0), 8) = date_we_want_to_analyse_on Then
found_files_to_analyse(i2) = strFile
i2 = i2 + 1
End If
End If
strFile = Dir
Wend
Do you want to consolidate files on the basis of file saved date or on the basis of the name of the file. A file named with yesterday's date can be saved today and will bear today's date. I guess you would have to parse the name of the file and apply logic around the date (in the file name) in a do while loop till all the files in the directory are searched for the condition. If the condition is met, you copy the opened file into a worksheet in your file. If the condition is not met, the file is skipped. Following might help
For each date which needs to be consolidated, do the following in a loop or an in a user prompted message box where the user inputs the date. You also need to chose whether you want the consolidation to happen in the workbook from where you are launching the macro or a separately opened workbook. The code below assumes you are consolidating in the same workbook.
Path = Path of the directory in which the files are stored
Flname = Dir(Path & "*.csv")
Do While Flname <> ""
If ' file check Condition' Then
Filecheckname = True ' Checks if file follows the naming conventions desired
Else
Filecheckname = False
End If
If Filecheckname Then
FlDate = getDate(Flname) ' extracts the date from the file name
Else
GoTo Errorhandler ' If there is an error, then the macro stops with a message to the user
End If
If FlDate<> Date Then
flsskpd = flsskpd + 1 ' If the date criteria is not met, the file is skipped with an increment to the fileskipped counter
Flname = Dir()
Else
Workbooks.Open Filename:=Path & Flname, ReadOnly:=True
'Code to Copy into consolidated workbook (ThisWorkbook)
filesmoved = filesmoved + 1
Flname = Dir()
End if
Loop
Message to user about how many files skipped and consolidated.
Prompt user whether to continue to the next date consolidation, if yes, continue or take the new date as an input and repeat the loop
If you want VBA to "search" for a file/folder in a directory, I think you need to use something like this:
Option Explicit
Option Compare Text
Public Enum xlSearchMode
xlFilesOnly = 0
xlFoldersOnly = 1
xlFilesAndFolders = 2
End Enum
Function SearchInDirectory(FName As String, Optional FoName As String, Optional SearchMode As xlSearchMode = xlFilesOnly, Optional ExactMatch As Boolean = True) As Variant
'By Abdallah Khaled Ali El-Yaddak
'Returns an array of strings with files/folders matching what you are searching for.
'If nothing is found, it returns an array of one empty string element.
'-------------'
'FName (String): The file/folder to look for
'[FoName] (String): The directory to search in, if omitted, CurDir will be used.
'[SreachMode] (xlSearchMode): xlFilesOnly (default) = Look for files only | xlFoldersOnly = Look for folders only | xlFilesAndFolders = Look for both
'[Exactmatch] (Boolean): True (default) = Look only for this string (case insenstive) | False = Sreach for any files/folders that includes this string in their name
Dim FSO As Object, File As Object, Folder As Object, Fnames() As String, i As Long, SubNames As Variant, SubFolder As Object
If FoName = "" Then FoName = CurDir
If Right(FoName, 1) <> "\" Then FoName = FoName & "\"
ReDim Fnames(1 To 1) As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(FoName)
If SearchMode = xlFilesOnly Or SearchMode = xlFilesAndFolders Then
For Each File In FSO.GetFolder(Folder).Files
If (ExactMatch And SubFolder.Name = FName) Or _
(Not ExactMatch And SubFolder.Name Like "*" & FName & "*") Then
Fnames(UBound(Fnames)) = File.Path
ReDim Preserve Fnames(1 To UBound(Fnames) + 1)
End If
Next
End If
If SearchMode = xlFoldersOnly Or SearchMode = xlFilesAndFolders Then
For Each SubFolder In FSO.GetFolder(Folder).subFolders
If (ExactMatch And SubFolder.Name = FName) Or _
(Not ExactMatch And SubFolder.Name Like "*" & FName & "*") Then
Fnames(UBound(Fnames)) = SubFolder.Path
ReDim Preserve Fnames(1 To UBound(Fnames) + 1)
End If
Next
End If
For Each SubFolder In FSO.GetFolder(Folder).subFolders
SubNames = SearchInDirectory(FName, SubFolder.Path, SearchMode, ExactMatch)
If SubNames(LBound(SubNames)) <> "" Then
For i = LBound(SubNames) To UBound(SubNames)
Fnames(UBound(Fnames)) = SubNames(i)
ReDim Preserve Fnames(1 To UBound(Fnames) + 1)
Next
End If
Next
If UBound(Fnames) > 1 Then ReDim Preserve Fnames(1 To UBound(Fnames) - 1)
SearchInDirectory = Fnames
End Function
To test, you need something like this:
Sub Test()
Dim a As Variant, i As Long
a = SearchInDirectory(date_we_want_to_analyse_on, folder_location, xlFilesOnly, Flase)
For i = LBound(a) To UBound(a)
Debug.Print a(i)
Next
End Sub
Notes:
This solution doesn't work on MAC (tested only on windows)
Searching will take longer for larger directories (The number of files/folders inside)