Consolidating Data from workbooks to a single worksheet

[Hommie]

I work at a Fire Department and we have Excel 2003 Preplans. Each preplan is in a workbook, with the name of owner, phone number and address. What we are wanting to do is consolidate the name, address and phone number from all workbooks to a single worksheet. In the new worksheet I am wanting to list all of these on seperate row.

As far as I knowall the data in the workbooks are in the same cell.

I don't really know VBA, but if its the only way, please tell me how to do it.

Thanks from a Fire Department!

 

[Hommie]

Sorry, Bump. We really need an answer to help our people.

Thanks in advance.

 

[Legacy 51064]

I use this code to consolidate all of my sheets to a master list. All of the sheets in the workbook have to be the same

Sub CopyFromWorksheets()
Dim wrk As Workbook
Dim sht As Worksheet
Dim trg As Worksheet
Dim rng As Range
Dim colCount As Integer

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

'If the dates have been already entered
If Worksheets("Summary").Range("X4").Value = "The dates are NOT active" Then

'Message Box
MsgBox ("The weekly start dates have not been added. You must activate the dates.")

Exit Sub

End If

Next sht

'Deactivate Screen Updating
Application.ScreenUpdating = True

'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 the column headers from the Second worksheet
Set sht = wrk.Worksheets(2)
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
.Font.Bold = True

End With

'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 the 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

'Reposition back on Enter
Sheets("Summary").Select

End Sub

 

[Hommie]

Now if I only knew VBA that would help me, could someone decipher?

 

[Legacy 51064]

I have shortened the code a little bit for you.

To install, [Alt-F11] then Insert / Module and paste into code window. Change the "Summary" to a sheet name in your workbook.

This code basically looks at the second worksheet and copies the column headers and pastes them into a new worksheet called "Master." It then takes all of the data in the remaining sheets and adds them to the "Master" sheet.

Sub CopyFromWorksheets()
Dim wrk As Workbook
Dim sht As Worksheet
Dim trg As Worksheet
Dim rng As Range
Dim colCount As Integer

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

'Deactivate Screen Updating
Application.ScreenUpdating = True

'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 the column headers from the Second worksheet
Set sht = wrk.Worksheets(2)
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
.Font.Bold = True

End With

'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 the 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

'Reposition back on Enter
Sheets("Summary").Select

End Sub