Open files in order

[Sandy]

I am trying to modify Ron de Bruins code to open all files in a directory.
Sub Example2()
Dim MyPath As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long
Dim Fnum As Long
Dim mybook As Workbook
Dim basebook As Workbook
Dim sourceRange As range
Dim destrange As range
Dim rnum As Long

'Fill in the path\folder where the files are
'MyPath = "C:\Data" or on a network :
MyPath = "\\ComputerName\YourFolder"

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xls")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

On Error GoTo CleanUp
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
'clear all cells on the first sheet
basebook.Worksheets(1).Cells.Clear
rnum = 1

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
Set sourceRange = mybook.Worksheets(1).range("A1:C1")
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).range("A" & rnum)

' This will add the workbook name in column D if you want
basebook.Worksheets(1).Cells(rnum, "D").Value = mybook.Name

sourceRange.Copy destrange
' Instead of this line you can use the code below to copy only
the values

' With sourceRange
' Set destrange =
basebook.Worksheets(1).Cells(rnum, "A"). _
'
Resize(.Rows.Count, .Columns.Count)
' End With
' destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
mybook.Close savechanges:=False
Next Fnum
End If
CleanUp:
Application.ScreenUpdating = True
End Sub

My files are saved as filenameyymmdd.xls and I need to open and copy in date
order but the code is opening newest last. What do I change to get them to
open oldest first?

Thanks!

 

[Sandy]

One other thing-----
I will be copying range A1:R1 and I would like to transpose copy to colum A.
Thanks!

 

[Bob Phillips]

I would think you would need to read the filenames into an array and then
sort the array, and then open them from there.

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

 

[Sandy]

And how would I do that?

I would think you would need to read the filenames into an array and then
sort the array, and then open them from there.

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

 

[Dave Peterson]

Add this at the bottom of your module:

Function SortArray(myArr As Variant) As Variant
Dim iCtr As Long
Dim jCtr As Long
Dim Temp As Variant

For iCtr = LBound(myArr) To UBound(myArr) - 1
For jCtr = iCtr + 1 To UBound(myArr)
If LCase(Right(myArr(iCtr), 10)) _

LCase(Right(myArr(jCtr), 10)) Then

Temp = myArr(iCtr)
myArr(iCtr) = myArr(jCtr)
myArr(jCtr) = Temp
End If
Next jCtr
Next iCtr
End Function

Then replace some of your existing code:

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
'yymmdd.xls
If LCase(Right(FilesInPath, 10)) Like "*######.xls" Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
End If
FilesInPath = Dir()
Loop

If Fnum > 0 Then
MyFiles = SortArray(MyFiles)
'keep going with other code.

========
And if you have dates in the last century, your sort will be off. I like to
include 4 digit years to stop that problem.

 

[Sandy]

Dave thanks for the reply!
This is what I have so far

Sub Example2()
Dim MyPath As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long
Dim Fnum As Long
Dim mybook As Workbook
Dim basebook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim sfolder As String

sfolder = ThisWorkbook.Path

'Fill in the path\folder where the files are
'MyPath = "C:\Data" or on a network :
MyPath = sfolder
MsgBox (MyPath)

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xls")
MsgBox (FilesInPath)
If FilesInPath = "" Then
MsgBox "No files found"

Exit Sub
End If

On Error GoTo CleanUp
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
'clear all cells on the first sheet
basebook.Worksheets(1).Cells.Clear
rnum = 1

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
MsgBox (FilesInPath)
'yymmdd.xls
If LCase(Right(FilesInPath, 10)) Like "*######.xls" Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
End If
FilesInPath = Dir()
Loop


'Loop through all files in the array(myFiles)
If Fnum > 0 Then
MyFiles = SortArray(MyFiles)
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
Set sourceRange = mybook.Worksheets(1).Range("g2:ae2")
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Range("A" & rnum)

' This will add the workbook name in column D if you want
basebook.Worksheets(1).Cells(rnum, "D").Value = mybook.Name

' sourceRange.Copy destrange
' Instead of this line you can use the code below to copy only
the Values

With sourceRange
Set destrange =
basebook.Worksheets(1).Cells(rnum, "A"). _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
mybook.Close savechanges:=False
Next Fnum
End If
CleanUp:
Application.ScreenUpdating = True
End Sub
Function SortArray(myArr As Variant) As Variant
Dim iCtr As Long
Dim jCtr As Long
Dim Temp As Variant

For iCtr = LBound(myArr) To UBound(myArr) - 1
For jCtr = iCtr + 1 To UBound(myArr)
If LCase(Right(myArr(iCtr), 10)) _

LCase(Right(myArr(jCtr), 10)) Then

Temp = myArr(iCtr)
myArr(iCtr) = myArr(jCtr)
myArr(jCtr) = Temp
End If
Next jCtr
Next iCtr
End Function

It runs through the sort and then ends. What am I missing?
Thanks!

 

[Dave Peterson]

Try using this Sub instead of the function:

Sub SortArray(myArr As Variant)
Dim iCtr As Long
Dim jCtr As Long
Dim Temp As Variant

For iCtr = LBound(myArr) To UBound(myArr) - 1
For jCtr = iCtr + 1 To UBound(myArr)
If LCase(Right(myArr(iCtr), 10)) _

LCase(Right(myArr(jCtr), 10)) Then

Temp = myArr(iCtr)
myArr(iCtr) = myArr(jCtr)
myArr(jCtr) = Temp
End If
Next jCtr
Next iCtr
End Sub

And change the
myfiles = sortarray(myfiles)
to
Call SortArray(MyFiles)

 

[Dave Peterson]

ps. That on error statement hides any errors. When you're debugging (or I'm
debugging), it's a good idea to comment that out to help find the problem.

 

[Sandy]

Thanks Dave
This is what I have so far. It appears as though the routine stops after
the sort array bit. When I run the code it highlightst he End Sub for Sort
Array but doesnt give an error message.

Thanks!

 

[Sandy]

I have it now thanks!
A followup question:
This code creates a grid with dates in A2:A31 and hourly data is in B2:Y31,
with hours 1-24 listed in B1:Y1. Then on sheet2 colA is date/time dd/mm/yyyy
hh:mm. Hww would I look up the coresponding values in the grid for for each
Date/Time on sheet2?

 

[Dave Peterson]

=index(match())???

You may want to read Debra Dalgleish's notes:
http://www.contextures.com/xlFunctions02.html (for =vlookup())
and
http://www.contextures.com/xlFunctions03.html (for =index(match()))

I have it now thanks!
A followup question:
This code creates a grid with dates in A2:A31 and hourly data is in B2:Y31,
with hours 1-24 listed in B1:Y1. Then on sheet2 colA is date/time dd/mm/yyyy
hh:mm. Hww would I look up the coresponding values in the grid for for each
Date/Time on sheet2?

 

[Sandy]

Great! Thansk so much for your help!

=index(match())???

You may want to read Debra Dalgleish's notes:
http://www.contextures.com/xlFunctions02.html (for =vlookup())
and
http://www.contextures.com/xlFunctions03.html (for =index(match()))