Import Data from Multiple Sources

[Mark]

Hi,
I’m trying to import data from the last sheet of multiple workbooks into one
of five predetermined worksheets in a new workbook. I haven’t seen anything
on how to do this in the newsgroup and it doesn’t appear that I can use ADO
to accomplish it, so I’ve plagiarized Ron de Bruin’s code to this point. What
I have is five folders (grades 1 through 5) that contain between 28 and 31
class workbooks from each school. Each class workbook contains four sheets
and each sheet will contain at least fifteen rows of student data. I only
need the data from the last sheet("May"), less the last two rows of summary
data. In a new workbook there will be five sheets (grades 1 through 5). I
need all of the data from the last sheet of every workbook in each folder
imported into each corresponding sheet in the new workbook.. Any help would
be greatly appreciated. Thanks.
Mark

Sub MergeAllWorkbooks()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long, n As Long


' Change this to the path\folder location of your files.
MyPath = "C:\Documents and Settings\HP_Owner\My Documents\2008_2009\"


' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

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

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

' Set various application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

' Add a new workbook with one sheet.
Application.Workbooks.Add Template:="C:\Documents and
Settings\HP_Owner\Application Data\Microsoft\Templates\Repository.xlt"
rnum = 1

' Loop through all files in the myFiles array.
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0

If Not mybook Is Nothing Then
On Error Resume Next

' Change this range to fit your own needs.
With mybook.Worksheets("Spring")
n = Cells(Rows.Count, "A").End(xlUp).Row
Set sourceRange = .Range("A13:z" & n)
End With

If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If source range uses all columns then
' skip this file.
If sourceRange.Columns.Count >= BaseWks.Columns.Count
Then 'blows up here
Set sourceRange = Nothing
End If
End If
On Error GoTo 0

If Not sourceRange Is Nothing Then

SourceRcount = sourceRange.Rows.Count

If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "There are not enough rows in the target
worksheet."
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else

' Copy the file name in column A.
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(FNum)
End With

' Set the destination range.
Set destrange = BaseWks.Range("A" & rnum)

' Copy the values from the source range
' to the destination range.
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count,
..Columns.Count)
End With
destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If

Next FNum
BaseWks.Columns.AutoFit
End If

ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub

 

[Ron de Bruin]

Are the five sub folders below one folder ?

Let me know and I will post a example for you this evening Mark

 

[Mark]

Thanks, Ron. Yes, the five folders are subfolders of "2008_2009".

 

[Ron de Bruin]

Hi Mark

Test this one for me, I hope I understand you correct ?

To test open a new workbook and copy the code below in a normal module in this workbook
If it is working OK we can change DestWB to the template

Change the five lines in the first macro that you must Run (you only run the macro "Call_Merge_Macro")

Call MergeTest("C:\Users\Ron\test\1", 4, 1)

path of the folder
index of the sheet you want to copy from (sheet 4 you say)
index of the sheet you want to copy to (1 for the first folder, 2 for the second,.......)


'Start code

Dim DestWB As Workbook

Sub Call_Merge_Macro()
Set DestWB = ThisWorkbook
Call MergeTest("C:\Users\Ron\test\1", 4, 1)
Call MergeTest("C:\Users\Ron\test\2", 4, 2)
Call MergeTest("C:\Users\Ron\test\3", 4, 3)
Call MergeTest("C:\Users\Ron\test\4", 4, 4)
Call MergeTest("C:\Users\Ron\test\5", 4, 5)
End Sub

Sub MergeTest(MyPath As String, CopyShNum As Long, DestShNum As Long)
Dim FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long

'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 & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

'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

'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

'Add a new workbook with one sheet
Set BaseWks = DestWB.Worksheets(DestShNum)
rnum = 1

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0

If Not mybook Is Nothing Then

On Error Resume Next

With mybook
Set sourceRange = .Worksheets(CopyShNum).Range("A1:Z" & LastRow(.Worksheets(CopyShNum)) - 2)
End With

If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0

If Not sourceRange Is Nothing Then

SourceRcount = sourceRange.Rows.Count

If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else

'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(Fnum)
End With

'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)

'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If

Next Fnum
BaseWks.Columns.AutoFit
End If

ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

 

[Mark]

Ron,
All I can say is "Excellent!" Your code worked great! The only question I
have is where, or how, do I add the workbook based on the template
("Repository.xlt)?
Mark

 

[Mark]

Sorry, Ron, the template question was stupid - I just needed to pull my head
out, so I could see for myself. Thanks again for your help, I really
appreciate it, and you did excellent work. Thanks.
Mark

 

[Ron de Bruin]

Good morning Mark

You are welcome

 

[Ron de Bruin]

Btw: my Example copy to column Z
You can change it in this line

Set sourceRange = .Worksheets(CopyShNum).Range("A1:Z" & LastRow(.Worksheets(CopyShNum)) - 2)

 

[Mark]

Thanks, Ron. I think I'll keep it the way it is as it works perfectly.
Mark