Solved: Copy data from multiple files to a single worksheet

[Blue_Bunny]

Hi All -

I am somewhat embarrassed that I am "crying uncle" on this one ...

I have conducted quite a bit of research and wasted the better part of the day trying to tinker with solutions, but now I am throwing in the towel.

Quick summary:

I want to merge data from multiple files into a single workbook.

Here are the details:

1.) I would like to use one of the MSOFileDialog Objects to prompt the user to select files from a folder. My goal is to place this code into an add-in that the user will use to kick off this Sub. We can refer to this as Workbook 1.

2.) I only want to process the first worksheet from each file. I was thinking of using worksheets(1) versus worksheets("filename_with_a_Variable").

3.) I would like to add a new worksheet to the original workbook (Workbook 1) that is housing the macro and combine all the data found in the selected files. Again, I only need to process the first worksheet of each selected file. All the sheets will be the same, so the column heading should come along during the first copy of the first sheet in the first file selected, and then the rest of the data can go right below the "last used range" of the master worksheet.


What I have been trying to do is combine these two macros as follows:

[VBA]

Sub FilePicker()
Dim FD As Office.FileDialog
Dim file As Variant
Dim message As String

Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
If .Show Then
For Each file In .SelectedItems

'****PLACE THE OTHER MACRO HERE***********
Next
End If
End With
End Sub

[/VBA]

And place this macro inside the FOR EACH / NEXT:

[VBA]
Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets

Set wrk = ActiveWorkbook 'Working in active workbook

For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht

'We don't want screen updating
Application.ScreenUpdating = False

'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With

'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit

'Screen updating should be activated
Application.ScreenUpdating = True
End Sub
[/VBA]

The second macro assumes that each of the worksheets to be copied are all located in the same workbook. I would try to create a solution that holds the information in VBA, pastes it in the aggregate / master worksheet, drops it and moves on to the next selected file instead of actually writing the data to a separate worksheets in Workbook 1.

Both of these macros work great independently ... I just can't combine them - HA!

Thanks in advance!

The BlueOne

[GTO]

Hi BlueOne,

...I want to merge data from multiple files into a single workbook...

...I only want to process the first worksheet from each file. ...

...Again, I only need to process the first worksheet of each selected file...

...The second macro assumes that each of the worksheets to be copied are all located in the same workbook...

Maybe just me, but this threw me a bit. I am presuming that you want the first sheet from ea source wb chosen.

I would like to add a new worksheet to the original workbook (Workbook 1) that is housing the macro and combine all the data found in the selected files.

Okay, I wrote this aimed at the activeworkbook, as you state that you want to end up writing an add-in. If I was aiming the data at ThisWorkbook, I would remain explicit at ThisWorkbook.

Here's a stab, see if its in the ballpark?
In a Standard Module:
[vba]Option Explicit

Sub Main()
Dim FD As FileDialog, FilePath As Variant, wbDest As Workbook, _
wksDest As Worksheet, rngNext As Range, strShName As String, _
i As Long, aryFileNames As Variant, aData As Variant

Set FD = Application.FileDialog(msoFileDialogFilePicker)
If FD.Show Then
ReDim aryFileNames(1 To FD.SelectedItems.Count)
For Each FilePath In FD.SelectedItems
i = i + 1
aryFileNames(i) = FilePath
Next
Else
MsgBox "No files picked...", vbOKOnly, vbNullString
Exit Sub
End If

Set wbDest = ActiveWorkbook
strShName = "Master"
i = 0
Do While ShExists(strShName, wbDest)
i = i + 1
strShName = strShName & "_Copy" & Format(i, "000")
Loop

Set wksDest = wbDest.Worksheets.Add(After:=wbDest.Worksheets(wbDest.Worksheets.Count), _ Type:=xlWorksheet)
wksDest.Name = strShName

For i = 1 To UBound(aryFileNames)
aData = vbNullString
If SourceFile_ExtractData(aryFileNames(i), i, aData) Then

Set rngNext = RangeFound(wksDest.Cells)
If rngNext Is Nothing Then
Set rngNext = wksDest.Cells(1)
Else
Set rngNext = wksDest.Cells(RangeFound(wksDest.Cells).Row, 1).Offset(1)
End If

If IsArray(aData) Then
rngNext.Resize(UBound(aData, 1), UBound(aData, 2)).Value = aData
End If
End If
Next
End Sub

Function SourceFile_ExtractData(ByVal FileFullName As String, _
ByVal FilNum As Long, _
ByRef aData As Variant) As Boolean
Dim _
wbSource As Workbook, _
wksSource As Worksheet, _
rngLRow As Range, _
rngLCol As Range, _
rngData As Range, _
lLRow As Long

Static lLCol As Long

On Error GoTo Terminate
Set wbSource = Workbooks.Open(FileFullName, False, True)
Set wksSource = wbSource.Worksheets(1)

If FilNum = 1 Then
With wksSource
Set rngLCol = RangeFound(.Rows(1), , , , , xlByColumns)
If rngLCol Is Nothing Then
MsgBox .Name & " has an empty first sheet. Closed w/o data extraction.", _
vbInformation, vbNullString
Exit Function
End If
lLCol = rngLCol.Column
Set rngLRow = RangeFound(.Cells)
lLRow = rngLRow.Row
Set rngData = Range(.Range("A1"), .Cells(lLRow, lLCol))
aData = rngData.Value
End With
Else
With wksSource
Set rngLRow = RangeFound(.Cells)
lLRow = rngLRow.Row
Set rngData = Range(.Range("A2"), .Cells(lLRow, lLCol))
aData = rngData.Value
End With
End If
wbSource.Close False
SourceFile_ExtractData = True
Exit Function
Terminate:
On Error Resume Next
wbSource.Close False
End Function

Function RangeFound(SearchRange As Range, _
Optional ByVal FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range

If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange.Cells(1)
End If
Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function

Function ShExists(ShName As String, _
Optional wb As Workbook, _
Optional CheckCase As Boolean = False) As Boolean

If wb Is Nothing Then
Set wb = ThisWorkbook
End If

If CheckCase Then
On Error Resume Next
ShExists = CBool(wb.Worksheets(ShName).Name = ShName)
On Error GoTo 0
Else
On Error Resume Next
ShExists = CBool(UCase(wb.Worksheets(ShName).Name) = UCase(ShName))
On Error GoTo 0
End If
End Function[/vba]

***To All***
I am totally unsure about using Resume Next in an error handler; I am sorely lacking in error handling. Comments or criticisms welcome.

1. Would the current work?
2. A better way?

Mark

[Blue_Bunny]

GTO -

You kicked some serious code tail on this - it works perfectly!

I would like to sincerely thank you!



The BlueOne

[Bob Phillips]

***To All***
I am totally unsure about using Resume Next in an error handler; I am sorely lacking in error handling. Comments or criticisms welcome.

1. Would the current work?
2. A better way?

Mark

I see nothing at all wrong with the way that you are using it, setting it to suppress an anticipated error, and resetting immediately afterwards. The only difference that I apply is that I delegate anticipated errors like that into single task functions that contain the error handling.

[GTO]

I see nothing at all wrong with the way that you are using it, setting it to suppress an anticipated error, and resetting immediately afterwards.

If only I had a brain...

Apologies for my lack of clarity, as I forgot the error handling in ShExists() and now am not sure if we are both referring to the same bit. I think so, as I referred to having the Resume Next in the handler, but just to ensure, I am asking about the tail end of SourceFile_ExtractData().

While I failed to include an On Error GoTo 0, from my understanding, as the function is called but calls no other function, the error handling would revert to whatever is in the calling sub upon exiting the function. (In this case, no error handling in the calling sub) Do I have that part right?

The only difference that I apply is that I delegate anticipated errors like that into single task functions that contain the error handling.

If we are referring to the same bit, I do not understand how this would work?

Thank you for your patience Bob; it is always appreciated.

Mark