merging data/worksheets

[joec]

I am charged with combining data from 12 different excel workbooks into one
worksheet. Each workbook has data entered on 5 different worksheets. All of
the column headings are identical. What I need is for certain results from
each worksheet to merge into 1 worksheet without overriding each other. And
with the ability to add more data at a later time. Is this possible to
achieve?

 

[Bernie Deitrick]

Joe,

You could use a macro to combine all the data, then sort or filter the data based on your criteria.

Below is a macro that will combine all the sheets in all the files that you select into one sheet,
in the workbook where you have the macro.

HTH,
Bernie
MS Excel MVP

Option Explicit
Sub Consolidate()
' Will consolidate Mulitple Sheets
' from Multiple Files onto one sheet
' Assumes that all data starts in cell A1 and
' is contiguous, with no blanks in column A

Dim FileArray As Variant
Dim i As Integer
Dim myBook As Workbook
Dim mySheet As Worksheet
Dim Basebook As Workbook
Dim CopyHeaders As Boolean
Dim NewName As Variant


'Coded like this to allow flexibility in future use
Set Basebook = ThisWorkbook
CopyHeaders = True

FileArray = Application.GetOpenFilename(MultiSelect:=True)

With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With

If IsArray(FileArray) Then
For i = LBound(FileArray) To UBound(FileArray)
Set myBook = Workbooks.Open(FileArray(i))
For Each mySheet In myBook.Worksheets
mySheet.Activate
Range("A1").CurrentRegion.Offset(IIf(CopyHeaders, 0, 1)).Copy _
Basebook.Worksheets(1).Range("C65536").End(xlUp).Offset(1, 0)
If CopyHeaders Then
CopyHeaders = False
With Basebook.Worksheets(1).Range("A65536").End(xlUp)
.Offset(1, 0).Value = "Workbook Name"
.Offset(1, 1).Value = "Sheet Name"
End With
End If
With Basebook.Worksheets(1)
.Range(.Range("A65536").End(xlUp).Offset(1, 0), _
.Range("C65536").End(xlUp).Offset(0, -2)).Value = _
myBook.Name
.Range(.Range("B65536").End(xlUp).Offset(1, 0), _
.Range("C65536").End(xlUp).Offset(0, -1)).Value = _
mySheet.Name
End With
Next mySheet
myBook.Close
Next i
Else:
MsgBox "You clicked cancel"
End If

With Application
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End With


If MsgBox("Do you want to save this under a new name?", vbYesNo) = vbYes Then
NewName = Application.GetSaveAsFilename( _
InitialFileName:=Basebook.Path & "\" & _
Basebook.Name, FileFilter:="Excel Workbooks (*.xls), *.xls")
If NewName <> False Then
If Dir(NewName) <> "" Then
Select Case MsgBox("File Exists. Overwrite ?", vbYesNoCancel + vbQuestion)
Case vbYes
Application.DisplayAlerts = False
Basebook.SaveAs Filename:=NewName, FileFormat:=xlWorkbookNormal
Application.DisplayAlerts = True
Case vbNo
Do
NewName = Application.GetSaveAsFilename( _
InitialFileName:=Basebook.Path & "\" & _
Basebook.Name, FileFilter:="Excel Workbooks (*.xls),
*.xls")
If NewName = False Then Exit Sub
Loop Until Dir(NewName) = ""
Basebook.SaveAs Filename:=NewName, FileFormat:=xlWorkbookNormal
Case Else
Exit Sub
End Select
Else
Basebook.SaveAs Filename:=NewName, FileFormat:=xlWorkbookNormal
End If
End If

End If

End Sub