Solved: Combine Multiple Workbooks Into A Summary Sheet

[hobbiton73]

Hi I wonder whether someone may be able to help me please.

I'm using the code below to allow the user to copy a given range from multiple workbooks amalgamating them into one 'Summary' sheet.

Sub Merge()
Dim DestWB As Workbook, WB As Workbook, WS As Worksheet, SourceSheet As String
Set DestWB = ActiveWorkbook
SourceSheet = "Combined"
StartRow = 5
FileNames = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*),*.xls*", _
Title:="Select the workbooks to merge.", MultiSelect:=True)
If IsArray(FileNames) = False Then
If FileNames = False Then
Exit Sub
End If
End If
For n = LBound(FileNames) To UBound(FileNames)
Set WB = Workbooks.Open(Filename:=FileNames(n), ReadOnly:=True)
For Each WS In WB.Worksheets
If WS.Name = SourceSheet Then
With WS
If .UsedRange.Cells.Count > 1 Then
dr = DestWB.Worksheets("Combined").Range("A" & Rows.Count).End(xlUp).Row + 1
Lastrow = .Range("A" & Rows.Count).End(xlUp).Row
For j = Lastrow To StartRow Step -1
If Range("E" & j) <> "Requirements" And Range("E" & j) <> "R & D Lead" And Range("E" & j) <> "Technical" And Range("E" & j) <> "Analyst" Then Rows(j).Delete
Next
Lastrow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A" & StartRow & ":AD" & Lastrow).Copy
DestWB.Worksheets("Combined").Cells(dr, "A").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
Application.CutCopyMode = False
End If
End With
WB.Close savechanges:=False
Exit For
End If
Next WS
Next n
End Sub
The code works fine, but I have a problem if the values in column 'E' of the 'Source' files do not match the values in this line of code:

If Range("E" & j) <> "Requirements" And Range("E" & j) <> "R & D Lead" And Range("E" & j) <> "Technical" And Range("E" & j) <> "Analyst" Then Rows(j).Delete
The 'Source' file remains open rather than closing after the search.

I just wondered whether someone may be able to offer a little guidance please, on how I may go about changing this, so that no matter whether there are any matching records or not, the 'Source' file will close after the 'Search' function has taken place.

Many thanks and kind regards

[Teeroy]

Hi, I couldn't fault your code with a compliant spreadsheet and I don't think the IF statement is a problem. The only way I could come up with your error is if the 'Source' file doesn't contain a sheet named 'Combined'. This can be handled by moving your WB.close statement as per below. Let me know how it goes.

Sub Merge()
Dim DestWB As Workbook, WB As Workbook, WS As Worksheet, SourceSheet As String
'Set DestWB = ActiveWorkbook
Set DestWB = ThisWorkbook
SourceSheet = "Combined"
StartRow = 5
FileNames = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*),*.xls*", _
Title:="Select the workbooks to merge.", MultiSelect:=True)
If IsArray(FileNames) = False Then
If FileNames = False Then
Exit Sub
End If
End If
For n = LBound(FileNames) To UBound(FileNames)
Set WB = Workbooks.Open(Filename:=FileNames(n), ReadOnly:=True)
For Each WS In WB.Worksheets
If WS.Name = SourceSheet Then
With WS
If .UsedRange.Cells.Count > 1 Then
dr = DestWB.Sheets(SourceSheet).Range("A" & Rows.Count).End(xlUp).Row + 1
Lastrow = .Range("A" & Rows.Count).End(xlUp).Row
For j = Lastrow To StartRow Step -1
If Range("E" & j) <> "Requirements" And Range("E" & j) <> "R & D Lead" And Range("E" & j) <> "Technical" And Range("E" & j) <> "Analyst" Then Rows(j).Delete
'If Not (Range("E" & j) = "Requirements" Or Range("E" & j) = "R & D Lead" Or Range("E" & j) = "Technical" Or Range("E" & j) = "Analyst") Then Rows(j).Delete 'Testing rewrite
Next
Lastrow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A" & StartRow & ":AD" & Lastrow).Copy
DestWB.Worksheets("Combined").Cells(dr, "A").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
Application.CutCopyMode = False
End If
End With
'WB.Close savechanges:=False
Exit For
End If
Next WS
WB.Close savechanges:=False
Next n
End Sub

[hobbiton73]

Hi @Teeroy, thank you very much for taking the time to reply to my psot.

You were absolutely spot on, this seems to have eradicated the proble.

Once again, many thanks and all the best.

[hobbiton73]

Hi @teeroy, I'm sorry to toruble you again, but I wonder whether you may be able to help me please.

I've been testing all my code, just to make sure that everything works when the separate pieces I've been working on are put together.

I've come a cross a slight problem, when copying and pasting the Excel rows.

If there are no matching records in the 'Source' file, the code is incorrectly copying the header row, in row 6, and pastes this to the 'Destination' file.

I've been through the code bit by bit, and I don't understand why, particularly when I'm setting the range to copy from.

I just wondered whether you may be able to offer a little guidance on how i may go about solving this.

Many thanks and kind regards

[Teeroy]

If your header row is in row 6 then startrow should be 7, not 5 and you wouldn't get to it. Can you post an example workbook including the code you're using (in case it has changed) and some sample data (that's causing the problem) on a second sheet for testing?

[hobbiton73]

Hi @Teeroy, thnak you very much for your continued help with this, it is greatly appreciated.

Because the maximum amount of files you can attach is one, I've attached the 'Source' file, and the script for pulling the information into the 'Destination' file is as follows:

Sub Merge()
Dim DestWB As Workbook, WB As Workbook, WS As Worksheet, SourceSheet As String
Set DestWB = ActiveWorkbook
SourceSheet = "Input"
StartRow = 7
FileNames = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*),*.xls*", _
Title:="Select the workbooks to merge.", MultiSelect:=True)
If IsArray(FileNames) = False Then
If FileNames = False Then
Exit Sub
End If
End If
For n = LBound(FileNames) To UBound(FileNames)
Set WB = Workbooks.Open(Filename:=FileNames(n), ReadOnly:=True)
For Each WS In WB.Worksheets
If WS.Name = SourceSheet Then
With WS
If .UsedRange.Cells.Count > 1 Then
dr = DestWB.Worksheets("Input").Range("A" & Rows.Count).End(xlUp).Row + 1
Lastrow = .Range("A" & Rows.Count).End(xlUp).Row
For j = Lastrow To StartRow Step -1
If Range("E" & j) <> "Manager" And Range("E" & j) <> "R & D Lead" And Range("E" & j) <> "Technical" And Range("E" & j) <> "Analyst" Then Rows(j).Delete
Next
Lastrow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A" & StartRow & ":AC" & Lastrow).Copy
DestWB.Worksheets("Input").Cells(dr, "A").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
Application.CutCopyMode = False
End If
End With
'WB.Close savechanges:=False
Exit For
End If
Next WS
WB.Close savechanges:=False
Next n
End Sub

Many thanks and kind regards

[Teeroy]

Hi @hobbiton73,

You were setting "Lastrow" off column A which was empty, therefore Lastrow=1. I've set it to go off C (Names). This should stop your problems.

For future reference you could have included the data on a second worksheet of the workbook (including the code) or if you need to attach multiple files, Zip them.

Sub Merge()
Dim DestWB As Workbook, WB As Workbook, WS As Worksheet, SourceSheet As String
Set DestWB = ActiveWorkbook
SourceSheet = "Input"
StartRow = 7
FileNames = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*),*.xls*", _
Title:="Select the workbooks to merge.", MultiSelect:=True)
If IsArray(FileNames) = False Then
If FileNames = False Then
Exit Sub
End If
End If
For n = LBound(FileNames) To UBound(FileNames)
Set WB = Workbooks.Open(Filename:=FileNames(n), ReadOnly:=True)
For Each WS In WB.Worksheets
If WS.Name = SourceSheet Then
With WS
If .UsedRange.Cells.Count > 1 Then
dr = DestWB.Worksheets("Input").Range("C" & Rows.Count).End(xlUp).Row + 1
Lastrow = .Range("C" & Rows.Count).End(xlUp).Row
For j = Lastrow To StartRow Step -1
If Range("E" & j) <> "Manager" And Range("E" & j) <> "R & D Lead" And Range("E" & j) <> "Technical" And Range("E" & j) <> "Analyst" Then Rows(j).Delete
Next
Lastrow = .Range("C" & Rows.Count).End(xlUp).Row
.Range("A" & StartRow & ":AC" & Lastrow).Copy
DestWB.Worksheets("Input").Cells(dr, "A").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
Application.CutCopyMode = False
End If
End With
'WB.Close savechanges:=False
Exit For
End If
Next WS
WB.Close savechanges:=False
Next n
End Sub

[Teeroy]

Hi @hobbiton73,

The autofilter in your example gave me an idea. The following should be quicker.

Sub Merge2()
Dim DestWB As Workbook, WB As Workbook, WS As Worksheet, SourceSheet As String
Set DestWB = ActiveWorkbook
SourceSheet = "Input"
startrow = 7
Application.ScreenUpdating = False
On Error GoTo endsub
FileNames = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*),*.xls*", _
Title:="Select the workbooks to merge.", MultiSelect:=True)
If IsArray(FileNames) = False Then
If FileNames = False Then
Exit Sub
End If
End If
For n = LBound(FileNames) To UBound(FileNames)
Set WB = Workbooks.Open(Filename:=FileNames(n), ReadOnly:=True)
For Each WS In WB.Worksheets
If WS.Name = SourceSheet Then
With WS
If .UsedRange.Cells.Count > 1 Then
With Sheets("Input")
.AutoFilterMode = False
With .Range("C6:AC6")
.AutoFilter
.AutoFilter Field:=3, Criteria1:=Array( _
"Manager", "R & D Lead", "Technical", "Analyst"), Operator:=xlFilterValues
End With
End With
dr = DestWB.Worksheets("Input").Range("C" & Rows.Count).End(xlUp).Row + 1
lastrow = .Range("C" & Rows.Count).End(xlUp).Row
If lastrow >= startrow Then
.Range("A" & startrow & ":AC" & lastrow).SpecialCells(xlCellTypeVisible).Copy
DestWB.Worksheets("Input").Cells(dr, "A").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
End If
Application.CutCopyMode = False
End If
End With
Exit For
End If
Next WS
WB.Close savechanges:=False
Next n
endsub:
Application.ScreenUpdating = True
End Sub

[hobbiton73]

Hi @Teeruy,

Thank you very much for taking the time to put this together.

I've tried your final script and unfortunately I can't get this to work.

I can select the 'Source' file which opens correctly, but the information isn't copied to the 'Destination' file and the 'Source' file doesn't close.

Could you tell me please have you any ideas where I may be going wrong?

Many thanks and kind regards

[Teeroy]

My bad. I forgot the Autofilter method changed between excel 2003 and 2007; it won't work correctly on versions prior to 2007. Try the method per the post before it if your excel version is earlier than 2007.

[hobbiton73]

Hi @Teeroy, thnak you very much for your continued help with this it is greatly appreciated.

I have used the script you suggest, but unfortunately I still have the same problem, in that if there are no matching rows in the 'Source' file, the header row is paste into the 'Destination' file.

Many thanks and kind regards

[Teeroy]

Try this. After all rows of con-compliant data were deleted lastrow was finding the header. It now checks that any lastrow >= the startrow set.

Sub Merge()
Dim DestWB As Workbook, WB As Workbook, WS As Worksheet, SourceSheet As String
Set DestWB = ActiveWorkbook
SourceSheet = "Input"
startrow = 7
FileNames = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*),*.xls*", _
Title:="Select the workbooks to merge.", MultiSelect:=True)
If IsArray(FileNames) = False Then
If FileNames = False Then
Exit Sub
End If
End If
For n = LBound(FileNames) To UBound(FileNames)
Set WB = Workbooks.Open(Filename:=FileNames(n), ReadOnly:=True)
For Each WS In WB.Worksheets
If WS.Name = SourceSheet Then
With WS
If .UsedRange.Cells.Count > 1 Then
dr = DestWB.Worksheets("Input").Range("C" & Rows.Count).End(xlUp).Row + 1
lastrow = .Range("C" & Rows.Count).End(xlUp).Row
For j = lastrow To startrow Step -1
If Range("E" & j) <> "Manager" And Range("E" & j) <> "R & D Lead" And Range("E" & j) <> "Technical" And Range("E" & j) <> "Analyst" Then Rows(j).Delete
Next
lastrow = .Range("C" & Rows.Count).End(xlUp).Row
If lastrow >= startrow Then
.Range("A" & startrow & ":AC" & lastrow).Copy
DestWB.Worksheets("Input").Cells(dr, "A").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
Application.CutCopyMode = False
End If
End If
End With
'WB.Close savechanges:=False
Exit For
End If
Next WS
WB.Close savechanges:=False
Next n
End Sub

[hobbiton73]

Hi @Teeroy, this works absolutely brilliantly.

Thank you very much for all your time, trouble and effort, it is thoroughly appreciated.

All the best and kind regards

[Teeroy]

I'm glad it finally works for you, and you are welcome.