Merging and matching spreadsheets

[laandmc]

We have a set of Excel spreadsheets which are a list of values against
companies. From these we want to create a master spreadsheet which has all
the company names in alphabetical order in a column with the values from each
list in a separate column.

E.g.
Spreadsheet 1
Name, value1
A 1
B 4
C 4
E 2
F 1

Spreadsheet 2
Name, Value2
B 2
D 3
E 3
G 1
…………..

Spreadsheet N
Name, Value2
A 1
C 4
H 7

Master Spreadsheet
Name, Value1, Value2 ……. Value N
A 1 0 ……. 1
B 4 2 ……. 0
C 4 0 ……. 4
D 0 3 ……. 0
E 2 3 ……. 0
F 1 0 ……. 0
G 0 1 ……. 0
H 0 0 ……. 7

 

[Joel]

This will work

Sub combinesheets()

Set NewSht = Sheets.Add(after:=Sheets(Sheets.Count))
NewSht.Name = "Summary"
NewRow = 2
NewCol = 2
For Each Sht In Sheets
If Sht.Name <> "Summary" Then
NewSht.Cells(1, NewCol) = Sht.Name
RowCount = 1
Do While Sht.Range("A" & RowCount) <> ""
RowHeader = Sht.Range("A" & RowCount)
Data = Sht.Range("B" & RowCount)
Set c = NewSht.Columns("A").Find(what:=RowHeader, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
Range("A" & NewRow) = RowHeader
Cells(NewRow, NewCol) = Data
NewRow = NewRow + 1
Else
Cells(c.Row, NewCol) = Data
End If
RowCount = RowCount + 1
Loop
End If
NewCol = NewCol + 1
Next Sht
'fill in blanks with zeroes
LastCol = NewCol - 1
LastRow = NewRow - 1
For RowCount = 2 To LastRow
For ColCount = 2 To LastCol
If Cells(RowCount, ColCount) = "" Then
Cells(RowCount, ColCount) = 0
End If
Next ColCount
Next RowCount
End Sub

 

[Joel]

I made 3 minor changes
1) Changed the Colum header from the worksheet name to the value in cell B1
on each worksheet
2) Change name of new worksheet from Summary to Master
3) On master worksheet put the word "Name" in cell A1.




Sub combinesheets()

Set NewSht = Sheets.Add(after:=Sheets(Sheets.Count))
NewSht.Name = "Master"
Range("A1") = "Name"
NewRow = 2
NewCol = 2
For Each Sht In Sheets
If Sht.Name <> "Master" Then
NewSht.Cells(1, NewCol) = Sht.Range("B1")
RowCount = 1
Do While Sht.Range("A" & RowCount) <> ""
RowHeader = Sht.Range("A" & RowCount)
Data = Sht.Range("B" & RowCount)
Set c = NewSht.Columns("A").Find(what:=RowHeader, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
Range("A" & NewRow) = RowHeader
Cells(NewRow, NewCol) = Data
NewRow = NewRow + 1
Else
Cells(c.Row, NewCol) = Data
End If
RowCount = RowCount + 1
Loop
End If
NewCol = NewCol + 1
Next Sht
'fill in blanks with zeroes
LastCol = NewCol - 1
LastRow = NewRow - 1
For RowCount = 2 To LastRow
For ColCount = 2 To LastCol
If Cells(RowCount, ColCount) = "" Then
Cells(RowCount, ColCount) = 0
End If
Next ColCount
Next RowCount
End Sub

 

[Herbert Seidenberg]

Use Pivot Table.
No code, no formulas:
http://www.savefile.com/files/1729054