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)
Related
Scenario: I have a workbook with multiple worksheets. I am trying to use a function (called within a sub) to export arrays with data from certain worksheets. The arrays are created before the function with the content from the worksheet with:
If ws.Name = "AA" Then
expaa = ws.UsedRange.Value
End if
where expaa is previously defined as variant.
The function I am using apparently finishes running, but the output on the new file saved is weird: instead of having one row of headers, the first row is split into 2 for some reason (all the others remain the same).
This is the function I am using:
Function Exporter(arr As Variant, y As String, OutPath As String) As Variant
Dim lrow As Long, lColumn As Long
Dim w2 As Workbook
Dim d As Date
Workbooks.Add
Set w2 = ActiveWorkbook
w2.Worksheets(1).Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
Application.DisplayAlerts = False
w2.SaveAs Filename:=OutPath & "\" & y, FileFormat:=6
Application.DisplayAlerts = True
w2.Close True
End Function
Which I call from the main sub with:
If aa_name <> "" Then
Exporter expaa , "aa_OK", wbpath
End If
where aa_name is the name of the file used to retrieve the path.
Obs: The wbpath variable is a string with the path of my main workbook (therefore the new file is saved at the same location).
Question: What may be causing the first row of my output to be split? How can that be fixed?
Obs2: I know this can be done with copy procedure, and looping through the array and so on. I even got it to work with other methods. This post is only to understand what I am doing wrong with the current code.
Obs3: Regarding the data that is going to be passed: it is a matrix of days, identifiers and data, ex:
Item1 Item2 Item3
01/01/2000 1 1 2
02/01/2000 1 2 1
03/01/2000 2 2 2
with around 2000 rows and 3000 columns.
UPDATE: After retesting the code multiple times, It appears that the data of the first row only gets split when the file is save as csv (when the array is pasted, the output is normal). Any idea on what may be the cause for that?
I know this is old but here is my solution for the googlers. This accepts an array and creates a CSV at a path you define. Its probably not perfect but it has worked so far for me.
Option Explicit
Option Private Module
Public Function SaveTextToFile(ByVal targetarray As Variant, ByVal filepath As String) As Boolean
On Error GoTo CouldNotMakeFile
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim fileStream As TextStream
' Here the actual file is created and opened for write access
Set fileStream = fso.CreateTextFile(filepath)
' Write something to the file
Dim Row As Long, Col As Long
For Row = LBound(targetarray, 1) To UBound(targetarray, 1)
For Col = LBound(targetarray, 2) To UBound(targetarray, 2)
fileStream.Write StringCompliance(targetarray(Row, Col)) & IIf(Col = UBound(targetarray, 2), "", ",")
Next Col
fileStream.WriteBlankLines 1
Next Row
' Close it, so it is not locked anymore
fileStream.Close
' Here is another great method of the FileSystemObject that checks if a file exists
If fso.FileExists(filepath) Then
SaveTextToFile = True
End If
CouldNotMakeFile:
End Function
Private Function StringCompliance(ByVal InputString As String) As String
Dim CurrentString As String
CurrentString = InputString
'Test if string has qoutes
If InStr(CurrentString, Chr$(34)) > 0 Then
CurrentString = Chr$(34) & Replace(CurrentString, Chr$(34), Chr$(34) & Chr$(34)) & Chr$(34)
StringCompliance = True
Else
'Tets if string has commas or line breaks
If InStr(CurrentString, ",") > 0 Or InStr(CurrentString, vbLf) > 0 Then
CurrentString = Chr$(34) & CurrentString & Chr$(34)
Else
StringCompliance = False
End If
End If
StringCompliance = CurrentString
End Function
I try to open all *.xlsx files in a specified folder and store the filehandles in an array.
My code looks like this
Dim Files() As Workbook
ReDim Files(Count)
File = Dir(Path & "\*.xlsx")
Count = 0
Do While File <> ""
Set Files(Count) = Workbooks.Open(Path & File, , True)
Count = Count + 1
File = Dir()
Loop
The code seems to work, however, when I run it a second time (hitting the run button again), I get an error number 13.
Debugging the code I tracked the problem to the line
Set Files(Count) = Workbooks.Open(Path & File, , True)
As I am unexperienced with vba I guess I didn't do this the right way...
What would be a preferable way to store filehandles to all files in a specific folder in an array?
you're missing a path separator
Set Files(Count) = Workbooks.Open(Path & "\" & File, , True)
The code should be:
Dim Files() As Workbook
Dim Count As Integer
ReDim Files(Count)
File = Dir(Path & "\*.xlsx")
Count = 0
Do While File <> ""
ReDim Preserve Files(Count)
Set Files(Count) = Workbooks.Open(Path & File, , True)
Count = Count + 1
File = Dir()
Loop
You need to redim your array. Preserve keeps the existing data.
I have multiple "datasheet" text files that are used with a program at work and need to harvest values from them and combine it all into a spreadsheet.
The text files are formatted as such:
[File]
DescText = "1756-IF16H 16 Channel Hart Analog Input Module";
CreateDate = 04-07-10;
CreateTime = 10:29;
Revision = 1.1;
HomeURL = "http://www.ab.com/networks/eds/XX/0001000A00A30100.eds";
[Device]
VendCode = 1;
VendName = "Allen-Bradley";
ProdType = 10;
ProdTypeStr = "Multi-Channel Analog I/O with HART";
ProdCode = 163;
MajRev = 1;
MinRev = 1;
ProdName = "1756-IF16H/A";
Catalog = "1756-IF16H/A";
Icon = "io_brown.ico";
The Tags are consistent through all the files and each lines ends with a semicolon [ ; ] so I'm assuming this should be pretty easy. I need to pull "DescText","VendCode","ProdType","MajRev","MinRev",and"ProdName" into separate columns.
There are about 100 individual data files, each with a nonsensical filename, so I'm looking to have the macro just go through and open each one in the folder.
Thanks for the help, here is the solution I came up with for this specific problem
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
MyFolder = "[directory of files]"
MyFile = Dir(MyFolder & "\*.txt")
Dim filename As String
Dim currentrow As Integer: currentrow = 2
Do While Myfile <> "" 'This will go through all files in the directory, "Dir() returns an empty string at the end of the list
'For i = 1 To 500 'this was my debug loop to only go through the first 500 files at first
filename = MyFolder & "\" & MyFile 'concatinates directory and filename
Open filename For Input As #1
Do Until EOF(1) 'reads the file Line by line
Line Input #1, textline
'Text = Text & textline
If textline = "" Then 'error handler, if line was empty, ignore
Else
Dim splitline() As String
splitline() = Split(textline, "=", -1, vbTextCompare)
'because of how my specific text was formatted, this splits the line into 2 strings. The Tag is in the first element, the data in the second
If IsError(splitline(0)) Then
splitline(0) = ""
End If
Select Case Trim(splitline(0)) 'removes whitespace
Case "DescText"
currentrow = currentrow + 1
'files that didn't have a description row, resulted in empty rows in the spreadsheet.
ActiveSheet.Range("A" & currentrow).Cells(1, 1).Value = splitline(1)
Case "Revision"
ActiveSheet.Range("B" & currentrow).Cells(1, 1).Value = splitline(1)
Case "ProdCode"
ActiveSheet.Range("C" & currentrow).Cells(1, 1).Value = splitline(1)
Case "ProdType"
ActiveSheet.Range("D" & currentrow).Cells(1, 1).Value = splitline(1)
'...etc. etc... so on for each "tag"
End Select
End If
Loop
Close #1
MyFile = Dir() 'reads filename of next file in directory
'currentrow = currentrow + 1
'Next i
Loop
End Sub
here how I would solve the complete task:
Private Sub importFiles(ByVal pFolder As String)
' create FSO
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
' create folder
Dim oFolder As Object
Set oFolder = oFSO.getFolder(pFolder)
' go thru the folder
Dim oFile As Object
For Each oFile In oFolder.Files
' check if is a text file
If UCase(Right(oFile.Name, 4)) = ".TXT" Then
Debug.Print "process file: " & oFolder.Path & "\" & oFile.Name
readFile oFolder.Path & "\" & oFile.Name
End If
Next
' clean up
Set oFolder = Nothing
Set oFSO = Nothing
End Sub
Private Sub readFile(ByVal pFile As String)
' get new file handle
Dim hnd As Integer
hnd = FreeFile
' open file
Open pFile For Input As hnd
Dim sContent As String
Dim sLine As String
' read file
Do Until EOF(hnd)
Line Input #hnd, sLine
sContent = sContent & sLine
Loop
' close file
Close hnd
' extract requiered data
Debug.Print getValue(sContent, "ProdName")
Debug.Print getValue(sContent, "DescText")
End Sub
Private Function getValue(ByVal pContent As String, ByVal pValueName As String) As String
Dim sRet As String
sRet = ""
If InStr(pContent, pValueName) Then
pContent = Mid(pContent, InStr(pContent, pValueName) + Len(pValueName) + 2)
sRet = Left(pContent, InStr(pContent, ";") - 1)
sRet = Trim(sRet)
End If
getValue = sRet
End Function
Overall the solution contains 3 different procedures:
importFiles reads the content of a given directory (which has to be handed over as parameter) and if it finds a .txt file it calls readFile() and passes the full path of the file to it
readFile() opens the text file and stores the content in a string variable. After this is done it calles getValue for each value you are interessted in.
getValue analyses the given content and extractes the given value.
Simply adjust the calls of getValue() so that you get all values you are interessted in and store them instead of showing via debug.print and call the first procedure with the right directory like importFiles "C:\Temp"
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
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.