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.
Related
I need to merge 2 files into a new file using .vbs. Both files contains header and data. For header, I need to sum both files row count & also the total amount. For the data, I need to merge both data from these two files.
Header format:
yyyymmdd|FILENAME|row count|total amount
Sample of files & format as below:
File 1:
20160204|FILENAME|3|17
20160204|SARAH|OWEN|SCIENCE BOOK|20090717|USD|2|SCIENCE|0|
20160204|KYLE|PARKER|ENGLISH BOOK|20090717|USD|10|ENGLISH|0|
20160204|LILY|MORGAN|POLITICAL BOOK|20090717|USD|5|POLITICS|0|
File 2:
20160204|FILENAME|1|4
20160204|ADAM|HANSEL|HISTORY BOOK|20090717|USD|4|HISTORY|0|
Output:
20160204|FILENAME|4|21
20160204|SARAH|OWEN|SCIENCE BOOK|20090717|USD|2|SCIENCE|0|
20160204|KYLE|PARKER|ENGLISH BOOK|20090717|USD|10|ENGLISH|0|
20160204|LILY|MORGAN|POLITICAL BOOK|20090717|USD|5|POLITICS|0|
20160204|ADAM|HANSEL|HISTORY BOOK|20090717|USD|4|HISTORY|0|
I only managed to merge the two files. But it is not the output I want.
So far I only have this:
Const ForReading = 1
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOutputFile = objFSO.CreateTextFile("MYFILE.txt")
Set objTextFile = objFSO.OpenTextFile("D:\Testing\MYFILE1.txt", ForReading)
strText = objTextFile.ReadAll
objTextFile.Close
objOutputFile.WriteLine strText
Set objTextFile = objFSO.OpenTextFile("D:\Testing\MYFILE2.txt", ForReading)
strText = objTextFile.ReadAll
objTextFile.Close
objOutputFile.WriteLine strText
objOutputFile.Close
What you need to do is:
read the data rows of the two files
extract the 7th field of each data row
calculate the sum of all extracted values
write the new header with sum and total number of data rows
write all data rows to the file
For small-ish files one way would be something like this:
datafiles = Array("D:\Testing\MYFILE1.txt", "D:\Testing\MYFILE2.txt")
Set fso = CreateObject("Scripting.FileSystemObject")
Dim header
ReDim data(-1)
sum = 0
For Each filename In datafiles
Set f = fso.OpenTextFile(filename)
header = Split(f.ReadLine, "|")
Do Until f.AtEndOfStream
ReDim Preserve data(UBound(data)+1)
line = f.ReadLine
data(UBound(data)) = line
sum = sum + CInt(Split(line, "|")(6))
Loop
f.Close
Next
Set f = fso.CreateTextFile("MYFILE.txt")
f.WriteLine header(0) & "|" & header(1) & "|" & (UBound(data)+1) & "|" & sum
For Each row In data
f.WriteLine row
Next
f.Close
Beware that this won't perform too well for large files, though. If you need to process files like that you'll have to handle them differently (writing the data rows line by line to a temporary file instead of keeping them in memory, then writing header and merged data to the final file line by line in a second step).
Hope this helps:
<%
Class contFiles
Public Files
Private Sub Class_Initialize()
Set Files = Server.CreateObject("Scripting.Dictionary")
End Sub
Private Sub Class_Terminate()
If IsObject(Files) Then
Files.RemoveAll()
Set Files = Nothing
End If
End Sub
Public Sub addFile(theFileName)
Files.Add theFileName, theFileName
End Sub
Public Default Function makeFile(fileName)
On Error Resume Next
theKeys = Files.Keys
Set FSO = Server.CreateObject("Scripting.FileSystemObject")
Do Until IDx = Files.Count
Set TheTextStream = FSO.OpenTextFile(Server.MapPath(theKeys(IDx)), 1)
html = html & TheTextStream.ReadAll
IDx = IDx + 1
Loop
Set objTxt = FSo.CreateTextFile(Server.MapPath(fileName), True, False)
objTxt.Write(html)
objTxt.Close
If ( err.Number <> 0 ) Then
makeFile = False
Else
makeFile = True
End If
End Function
End Class
Set testFiles = New contFiles
testFiles.addFile("default.aspx")
testFiles.addFile("events.aspx")
testFiles.addFile("about.aspx")
response.write(testFiles.makeFile("test.txt"))
%>
I'm trying to combine an array of PDF into one with this code :
Option Explicit
Sub Fusion_PDFs(ByVal name As String, ByRef pdfs() As Variant)
Dim oPDDoc() As Object
Dim oPDDocFinal As Object
Dim Num As Long
Dim i As Integer
Set oPDDocFinal = CreateObject("AcroExch.PDDoc")
oPDDocFinal.Open (pdfs(0))
ReDim oPDDoc(UBound(pdfs))
For i = LBound(pdfs) + 1 To UBound(pdfs)
Set oPDDoc(i) = CreateObject("AcroExch.PDDoc")
oPDDoc(i).Open (pdfs(i))
Next i
For i = LBound(oPDDoc) To UBound(oPDDoc)
Num = oPDDocFinal.GetNumPages() - 1
oPDDocFinal.InsertPages Num, oPDDoc(i), 0, oPDDoc(i).GetNumPages(), True
Next i
oPDDocFinal.Save 1, ThisWorkbook.Path & "\DRT créés\" & name & ".pdf"
'Application.DisplayAlerts = False
For i = LBound(oPDDoc) To UBound(oPDDoc)
oPDDoc(i).Close
Set oPDDoc(i) = Nothing
Next i
oPDDocFinal.Close
Set oPDDocFinal = Nothing
'Application.DisplayAlerts = True
End Sub
I got a string array from another function which contains X path of pdfs. I already verified this array and there is nothing wrong with it, the problem is on this code. But i did a test version before rework it to works with my project, and the test version was working perfectly. The code is still very similar and i didn't change nothing on the creation and the fusion parts.
I first open an oPDDocFinal, which is the first pdf of my array "pdfs" (pdfs(0)) then i loop on the rest of the pdfs array to create a PDDoc array. Finally i loop on this PDDoc array to combine one by one all theses pdf with the oPDDocFinal.
But i got an error on this line :
oPDDocFinal.InsertPages Num, oPDDoc(i), 0, oPDDoc(i).GetNumPages(), True
i got the following error (i tried to translate from french) :
Execution error '91' :
Object variable or With bloc variable undefined
I didn't modified this part of code and it was working on my test script, but now i get this error. Do you know how can i solve my problem ?
Thanks for your attention.
Ok i found my error :
My first loop, i start at 1, so i take pdfs(1) to oPDDoc(1), but my first loop start at 0 so oPDDoc(0) doesn't exists.
I fixed it like that, and now it works :
Option Explicit
Sub Fusion_PDFs(ByVal name As String, ByRef pdfs() As Variant)
Dim oPDDoc() As Object
Dim oPDDocFinal As Object
Dim Num As Long
Dim i As Integer
Set oPDDocFinal = CreateObject("AcroExch.PDDoc")
oPDDocFinal.Open (pdfs(0))
ReDim oPDDoc(UBound(pdfs))
For i = LBound(pdfs) + 1 To UBound(pdfs)
Set oPDDoc(i - 1) = CreateObject("AcroExch.PDDoc")
oPDDoc(i - 1).Open (pdfs(i))
Next i
For i = LBound(oPDDoc) To UBound(oPDDoc) - 1
Num = oPDDocFinal.GetNumPages() - 1
oPDDocFinal.InsertPages Num, oPDDoc(i), 0, oPDDoc(i).GetNumPages(), True
Next i
oPDDocFinal.Save 1, ThisWorkbook.Path & "\DRT créés\" & name & ".pdf"
'Application.DisplayAlerts = False
'For i = LBound(oPDDoc) To UBound(oPDDoc) - 1
'
' oPDDoc(i).Close
' Set oPDDoc(i) = Nothing
'
'Next i
'
'oPDDocFinal.Close
'Set oPDDocFinal = Nothing
'Application.DisplayAlerts = True
End Sub
Thanks all for your attention !
Things to try:-
Does the environment that it is not working on have the same version of AcroExch and Word installed
Can both environments see the PDFs?
Is there contention of oPDDocFinal meaning something or someone else has it open (This thread implies it should be closed to update).
In debug, does oPDDoc(i) have a value
should it be bracketed - oPDDocFinal.InsertPages(Num, oPDDoc(i), 0, oPDDoc(i).GetNumPages(), True)
I also believe you may have an easier debugging in a single loop.
Dim oPDDoc As Object
Dim oPDDocFinal As Object
Dim Num As Long
Dim i As Integer
'Initialise objects
Set oPDDocFinal = CreateObject("AcroExch.PDDoc")
Set oPDDoc = CreateObject("AcroExch.PDDoc")
'Save a working copy
oPDDocFinal.Open (pdfs(0))
oPDDocFinal.Save 1, ThisWorkbook.Path & "\DRT créés\" & name & ".pdf"
oPDDocFinal.Close
'Reference the working copy
pdfs(0) = ThisWorkbook.Path & "\DRT créés\" & name & ".pdf"
'for all but the first item in the pdfs array
For i = LBound(pdfs) + 1 To UBound(pdfs)
'Open the working copy
oPDDocFinal.Open (pdfs(0))
'Open the additional PDF
oPDDoc.Open (pdfs(i))
'Get the page count of the working copy
Num = oPDDocFinal.GetNumPages() - 1
'Insert the additional PDF at the end of the working copy
oPDDocFinal.InsertPages Num, oPDDoc(i), 0, oPDDoc(i).GetNumPages(), True
'Close the additional PDF
oPDDoc.Close
'Save and close the working copy PDF
oPDDocFinal.Save
oPDDocFinal.Close
Next i
'Release objects
Set oPDDocFinal = Nothing
Set oPDDoc = Nothing
This would be a heavyweight loop but should act as a starting point to debugging. I should also add I do not have AcroExch. The above is theoretical.
I have attached a code, however, this will only find the files that is present in the folder.
What I want to have is an incremental counter for the files. Thing is that sometimes the version will start something else than 0 or 1, e.g. 3.
Amesto non AN suppliers TEST W20-3 AN then I want the next string to be 4.
I am currently using this, but it will only work if 1 is the first, etc.
I am really stuck.
' Version check
Do While Len(Dir(strPath2 & "Amesto non AN suppliers TEST W" & week & "-" & version & "*.cif")) <> 0
version = version + 1
strPath = getDirectoryPath & "Amesto non AN suppliers TEST W" & week & "-" & version & " " & UserName & ".cif"
Loop
Sub loadversion()
Dim MyFile As String
Dim Counter As Long
'Create a dynamic array variable, and then declare its initial size
Dim DirectoryListArray() As String
ReDim DirectoryListArray(1000)
'Loop through all the files in the directory by using Dir$ function
MyFile = Dir$("C:\Users\niclas.madsen\Desktop\AP\WAVE3\CIF\*.*")
Do While MyFile <> ""
DirectoryListArray(Counter) = MyFile
MyFile = Dir$
Counter = Counter + 1
Loop
' do something here?!
If MyFile = vbNullString Then
Else
End If
'Reset the size of the array without losing its values by using Redim Preserve
ReDim Preserve DirectoryListArray(Counter - 1)
For Counter = 0 To UBound(DirectoryListArray)
'Debug.Print writes the results to the Immediate window (press Ctrl + G to view it)'
Debug.Print DirectoryListArray(Counter)
Next Counter
End Sub
To get the highest version on a filename in your directory, insert the following functions:
Function CheckHighestVersion(path As String, cutLettersAtWordBeginning As Integer) As Integer
Dim file As Variant
Dim toBeCut As String
Dim verLength As Integer
Dim highestVersion As Integer
highestVersion = 0
file = Dir(path)
While (file <> "")
toBeCut = file
toBeCut = Mid(toBeCut, cutLettersAtWordBeginning + 1)
verLength = FindVerLength(toBeCut)
If verLength = -1 Then
CheckHighestVersion = 0
Exit Function
End If
toBeCut = Left(toBeCut, verLength)
If Val(toBeCut) > highestVersion Then
highestVersion = Val(toBeCut)
End If
file = Dir
Wend
CheckHighestVersion = highestVersion
End Function
Function FindVerLength(fileName As String) As Integer
Dim i As Integer
For i = 1 To Len(fileName)
If Not IsNumeric(Mid(fileName, i, 1)) Then
If i = 1 Then
MsgBox "Couldn't obtain the highest version of the files: " & _
"The first letter of the version is not numeric. The letter is " & Mid(fileName, i, 1) & _
". Please use correct amount of letters to be cut at the beginning of the file name."
FindVerLength = -1
Exit Function
End If
FindVerLength = i - 1
Exit Function
End If
Next i
FindVerLength = i
End Function
Call CheckHighestVersion in your Sub. the path is only the directory (e.g. C:\Test\ ), the second parameter is the number of letters you don't need at the beginning of the word. If I counted correctly, that value should be 30+(length of week, week 25 would be 2, week 7 would be 1) in your case. The function returns the highest version contained in that folder.
I have a folder which contains a few excel files.
In each of those files I want to create an array which will contain the data in the "data" sheet. Each workbook or file has this worksheet.
Only problem is there could be a different number of files in the folder each time.
I want to capture the contents of the "data" worksheet of each file in an array each and then write all this data to one single file.
Question
Is it possible to dynamically create arrays based on for example the number of files in a folder?
If so how do you create those dynamic arrays?
Example
Instead of having one array (which I change the size of) I want to ...
(depending on the number of files in a folder for example create that many separate arrays?
e.g. 3 files in an folder
dim array01
dim array02
dim array03
Is it better to create one array per workbook in the folder - to store the contents of the "data" worksheet, or create one larger array?
Instead of using a multi-dimensional array and redim it all the time, consider storing each data array in a Collectionlike this:
Dim allData As Collection, data As Variant, file As Variant
Dim wb As Workbook, ws As Worksheet
Set allData = New Collection
file = Dir("c:\testfolder\*.xlsx")
While (file <> "")
Set wb = Workbooks.Open(file)
data = wb.Sheets(1).UsedRange.Cells 'Adjust this to get your data range
allData.Add data, file
file = Dir
Wend
Later you can use a For Each loop to retrieve the data:
Dim count As Integer
For Each data In allData
count = count + 1
Debug.Print "Dataset #" & count & " has " & _
UBound(data, 1) & " x " & UBound(data, 2) & " entries"
Next
Sub MAIN()
Dim FolderOfInterest As String, i As Long
FolderOfInterest = "C:\TestFolder"
Dim ary()
ary = files_in_folder(FolderOfInterest)
MsgBox "There are " & UBound(ary) & " files in folder " & FolderOfInterest
'
' Now store the array in a worksheet column
'
i = 1
For Each a In ary
Cells(i, "A").Value = a
i = i + 1
Next a
End Sub
Public Function files_in_folder(folderS As String) As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderS)
ReDim temp(1 To folder.Files.Count)
i = 1
For Each file In folder.Files
temp(i) = file.Name
i = i + 1
Next file
files_in_folder = temp
End Function
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)