Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Open files in order
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! |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Open files in order
One other thing-----
I will be copying range A1:R1 and I would like to transpose copy to colum A. Thanks! "Sandy" wrote: 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! |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Open files in order
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" wrote in message ... 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! |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Open files in order
And how would I do that?
"Bob Phillips" wrote: 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" wrote in message ... 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! |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Open files in order
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 wrote: And how would I do that? "Bob Phillips" wrote: 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" wrote in message ... 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! -- Dave Peterson |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Open files in order
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" wrote: 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 wrote: And how would I do that? "Bob Phillips" wrote: 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" wrote in message ... 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! -- Dave Peterson |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Open files in order
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) Sandy wrote: 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" wrote: 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 wrote: And how would I do that? "Bob Phillips" wrote: 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" wrote in message ... 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! -- Dave Peterson -- Dave Peterson |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
Open files in order
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. Dave Peterson wrote: 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) Sandy wrote: 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" wrote: 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 wrote: And how would I do that? "Bob Phillips" wrote: 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" wrote in message ... 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! -- Dave Peterson -- Dave Peterson -- Dave Peterson |
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
Open files in order
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! "Dave Peterson" wrote: 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. Dave Peterson wrote: 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) Sandy wrote: 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" wrote: 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 wrote: And how would I do that? "Bob Phillips" wrote: 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" wrote in message ... 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! -- Dave Peterson -- Dave Peterson -- Dave Peterson |
#10
Posted to microsoft.public.excel.programming
|
|||
|
|||
Open files in order
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" wrote: 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. Dave Peterson wrote: 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) Sandy wrote: 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" wrote: 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 wrote: And how would I do that? "Bob Phillips" wrote: 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" wrote in message ... 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! -- Dave Peterson -- Dave Peterson -- Dave Peterson |
#11
Posted to microsoft.public.excel.programming
|
|||
|
|||
Open files in order
=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())) Sandy wrote: 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" wrote: 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. Dave Peterson wrote: 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) Sandy wrote: 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" wrote: 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 wrote: And how would I do that? "Bob Phillips" wrote: 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" wrote in message ... 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! -- Dave Peterson -- Dave Peterson -- Dave Peterson -- Dave Peterson |
#12
Posted to microsoft.public.excel.programming
|
|||
|
|||
Open files in order
Great! Thansk so much for your help!
"Dave Peterson" wrote: =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())) Sandy wrote: 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" wrote: 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. Dave Peterson wrote: 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) Sandy wrote: 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" wrote: 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 wrote: And how would I do that? "Bob Phillips" wrote: 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" wrote in message ... 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
How to change default Open/Files of Type to "Microsoft Excel Files | Excel Discussion (Misc queries) | |||
open files in loop with date order | Excel Discussion (Misc queries) | |||
How to open files in order they were selected | Excel Discussion (Misc queries) | |||
How do you open multiple files in specifc order? | Excel Discussion (Misc queries) | |||
Macro to open *.dat files and save as .txt (comma delimited text files) | Excel Programming |