Merge Mutliple Excel Workbooks
- by IRHM
I wonder whether someone may be able to help me please.
I'm trying to use the code below to allow the user to select multiple Excel Workbooks, amalgamating the data into one 'Summary' sheet.
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
Select Case .Range("E" & j).Value
Case "Manager", "Lead", "Technical", "Analyst"
'do nothing
Case Else
.Rows(j).EntireRow.Delete
End Select
Next
lastrow = .Range("C" & Rows.Count).End(xlUp).Row
If lastrow >= startrow Then
.Range("B" & startrow & ":AD" & lastrow).Copy
DestWB.Worksheets("Input").Cells(dr, "B").PasteSpecial xlValues
.Range("AF" & startrow & ":AQ" & lastrow).Copy
DestWB.Worksheets("Input").Cells(dr, "AF").PasteSpecial xlValues
.Range("AS" & startrow & ":AS" & lastrow).Copy
DestWB.Worksheets("Input").Cells(dr, "AS").PasteSpecial xlValues
End If
End If
End With
Exit For
End If
Next WS
WB.Close savechanges:=False
Next n
End Sub
The code works fine except for one issue which I've been trying to solve for the last few weeks.
The following line of code looks in column E of the Source file, and if any of the entries match the values shown in the code it copies that row of data to paste into the Destination file.
If Range("E" & j) <> "Manager" And Range("E" & j) <> "Lead" And Range("E" & j) <> "Technical" And Range("E" & j) <> "Analyst" Then Rows(j).Delete
The problem I have is that if none of these values are found in the Source file, I receive the following error:
Run time error '1004':
Delete method of range class failed
and in Debug mode it highlights this part of the line as the source of the error, but I've no idea why.
Rows(j).Delete
I just wondered whether someone may be able to look at this please and let me know where I'm going wrong, or perhaps even suggest a more efficient process of allowing the user to merge the workbooks.
Many thanks and kind regards
