Looping thru multiple files to produce a consolidated summary by Code

[u473]

Filtering the postings on this subject did not produce satisfying
results.

Three worksheets to start with :
1. Code Table
Code Desc
A Code A Desc
B Code B Desc
C Code C Desc
D Code D Desc
E Code E Desc

2. Period1 Data
Code Value Date
B 2 .....
B 6 .....
D 3 .....

3. Period2 Data
Code Value Date
A 5 .....
B 3 .....
C 7 .....
D 4 .....
F 8 ......

Desired Output on the 4th worksheet,
considering that the F code was not in the original Code Table,
implying prompting for creation on the fly during the looping
Assume all the WorkSheets are in the same Workbook

Resulting Summary Table

Code Description Period1 Period2 Total
A Code A Desc 5 5
B Code B Desc 8 3 11
C Code C Desc 7 7
D Code D Desc 3 4 7
E Code E Desc 0 0
F Code F Desc 8 8
T O T A L 11 27 38

Can you help me,
Thank you

Celeste

 

[Zone]

u473, I have some code that might could be modified to do what you want.
Some questions:
1. Are all the codes and their descriptions listed in the Code Table on
Sheet 1?
2. Do all the tables begin in cell A1, with a heading row in row 1?
3. Will more periods be added and, if so, how many periods might there be
eventually?
James

 

[u473]

Thank you for your help.
Answers to your questions :
1. Are all the codes and their descriptions listed in the Code Table
on Sheet 1?
That is one of the issues. New codes will pop up in Periods.
I can either be prompted to enter them on the fly on the Code
Table
or populate an Exception worksheet, Both solutions are ok.
2. Do all the tables begin in cell A1, with a heading row in row 1?
Yes
3. Will more periods be added ? ; No How many periods might there
be eventually? : 12

 

[Zone]

Ok, I'll start diddling with the code to make it work for this. More
questions.
1. You say no more periods will be added, BUT there will be 12. Does this
mean you want to only show the additional periods on the combined table as
they are populated?
2. Do the tables have 2 heading rows, such as
Code Table
Code Descr
in rows 1 and 2, with data beginning in row 3 and
Period1 Data
Code Value Date
in rows 1 and 2, with data beginning in row 3, etc.?
James

 

[Joel]

The code get much more complicated if Code F is not on Sheet1. This macro
assume sheet1 contains all the codes and descriptions. Make sure worksheet
contains sheets 1 - 4. Add sheet 4 if it is missing.

Sub test()

'copy sheet1 to sheet4
Sheets("Sheet1").Cells.Copy _
Destination:=Sheets("Sheet4").Cells

'make header row on sheet4
With Sheets("Sheet4")
.Range("A1") = "CODE"
.Range("B1") = "DESCRIPTION"
.Range("C1") = "PERIOD1"
.Range("D1") = "PERIOD2"
.Range("E1") = "TOTAL"
End With

ShArray = Array("Sheet2", "Sheet3")

ColOff = 0
For Each wks In ShArray
With Sheets(wks)

LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
Set ShXColARange = .Range(.Cells(2, "A"), _
.Cells(LastRow, "A"))
Set ShXColBRange = .Range(.Cells(2, "B"), _
.Cells(LastRow, "B"))
End With
With Sheets("Sheet4")

LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set Sh4ColXRange = .Range(.Cells(2, "C").Offset(0, ColOff), _
.Cells(LastRow, "C").Offset(0, ColOff))

For Each cell In Sh4ColXRange

code = Cells(cell.Row, "A").Value
code_total = WorksheetFunction.SumIf( _
ShXColARange, code, ShXColBRange)
If code_total <> 0 Then
cell.Value = code_total
End If
Next cell
End With
ColOff = ColOff + 1
Next wks
With Sheets("Sheet4")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Cells(LastRow + 1, "A") = "TOTAL"
.Cells(LastRow + 1, "C").Formula = _
"=Sum(C2:C" & (LastRow) & ")"
.Cells(LastRow + 1, "D").Formula = _
"=Sum(D2" & (LastRow) & ")"
Set Sh4ColERange = .Range(.Cells(2, "E"), _
.Cells(LastRow, "E"))
For Each cell In Sh4ColERange
cell.Formula = _
"=Sum(C" & cell.Row & "" & cell.Row & ")"
Next cell
End With
End Sub

 

[OssieMac]

Hi,

I decided to take this on and it became a marathon. However, try what I have
and see how it goes.

I'm sure that I shouldn't have to tell you this but I will anyway. Make sure
that you have a backup of your workbook.

I have assumed that your code table all of your data column headers start at
cell A1 on each sheet.

Also assumes that worksheet 'Summary' exists.

You will need to rename your data sheets to just Period1, Period2, Period3
etc. This is because I made it dynamic for the number of data sheets and I
have used the sheet names on the Summary. I didn't want to start extracting
part of the name because when you get past Period9 there is more characters
etc and I am sure you understand.

Run the macro from Sub Summary_Data and it calls the second procedure.

Also it adds a worksheet called Temp. You can either leave it in or delete
it if you don't want it.

For the missing codes, it requests that you enter them. If no entry then the
procedure terminates.

Missing codes are appended to the codes in Code Table.


Option Explicit
Dim wsCode As Worksheet 'Code Table W'sheet
Dim rngCode As Range 'Code Table code Column
Dim rngData As Range 'Data in Data W'Sheets
Dim ws As Worksheet 'Each data W'sheet
Dim wsSumm As Worksheet 'Summary W'sheet
Dim rngSummCode As Range 'Codes in summary W'sheet
Dim cCode As Range 'Each cell in rngCode
Dim dCode As Range 'Each cell in rngData
Dim colNumb As Single 'Column # for summary headers
Dim colName As String 'Summary W'Sht Column names
Dim cellFound As Range 'Found cell in summary W'Sheet
Dim rngHeadSumm As Range 'Column headers in Summary W'Sht
Dim cHead As Range 'Each col header in Summary W'Sht
Dim rngSelect 'Selected range
Dim rngCodeDescr 'Range of descriptions
Dim c As Range 'each cell in rngSelect
Dim strTemp 'Code holder
Dim strInput 'Input box data
Dim rowNumb 'No of rows of data in summary

Sub Summary_Data()

Set wsCode = Worksheets("Code Table")

'Update Code Table from existing Code Table
'plus any new codes found in data.
Call Temp_Code_Table

With wsCode
Set rngCode = Range(.Cells(2, 1), _
.Cells(Rows.Count, 1).End(xlUp))
End With

'Create Summary sheet column headers from data sht names
Set wsSumm = Sheets("Summary")

With wsSumm
.Cells.Clear
.Cells(1, 1) = "Code"
.Cells(1, 2) = "Description"
colNumb = 2 'Initialize column number for headers
For Each ws In Worksheets
If Left(ws.Name, 6) = "Period" Then
colNumb = colNumb + 1
colName = ws.Name
.Cells(1, colNumb) = colName 'Col Head = Sht name
End If
Next ws
colNumb = colNumb + 1
.Cells(1, colNumb) = "Total"
Set rngHeadSumm = Range(.Cells(1, 1), _
.Cells(1, Columns.Count).End(xlToLeft))
End With

Sheets("Temp").Select
Range(Cells(2, 2), Cells(Rows.Count, 3).End(xlUp)).Copy _
Destination:=Sheets("Summary").Range("A2")


For Each cCode In rngCode
For Each ws In Worksheets
If Left(ws.Name, 6) = "Period" Then 'Is data sheet
With ws
Set rngData = Range(.Cells(2, 1), _
.Cells(Rows.Count, 1).End(xlUp))
End With
'Find column number matching data sht name
For Each cHead In rngHeadSumm
If cHead = ws.Name Then
colNumb = cHead.Column
Exit For
End If
Next cHead

ws.Select
rngData.Select

For Each dCode In rngData

If dCode = cCode Then 'Found in code table
'Find Summary col numb = data sht name
With wsSumm
Set rngSummCode = Range(.Cells(2, 1), _
.Cells(Rows.Count, 1).End(xlUp))
Set cellFound = rngSummCode.Find(What:=dCode, _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not cellFound Is Nothing Then 'Found
.Cells(cellFound.Row, colNumb) = _
.Cells(cellFound.Row, colNumb) _
+ dCode.Offset(0, 1)
End If
End With

End If
Next dCode

End If
Next ws
Next cCode

'Insert formulas for Totals
Sheets("Summary").Select
rowNumb = Cells(Rows.Count, 1).End(xlUp).Row
Rows("1:1").Select
Selection.Find(What:="Total", _
After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False).Activate

'Insert row totals
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "=SUM(RC3:RC[-1])"

ActiveCell.Copy _
Destination:=Range(ActiveCell, _
Cells(rowNumb, ActiveCell.Column))

'Insert column totals
Cells(rowNumb, ActiveCell.Column).Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "=SUM(R2C:R[-1]C)"

ActiveCell.Copy _
Destination:=Range(ActiveCell, _
Cells(rowNumb + 1, 3))

Cells(rowNumb + 1, 1) = "Totals"

Cells.Columns.AutoFit

End Sub


Sub Temp_Code_Table()

On Error Resume Next
Sheets("Temp").Select
On Error GoTo 0

'If sheet temp not already exists then add
If ActiveSheet.Name <> "Temp" Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Temp"
End If
Cells.Clear
Range("A1") = "Code"

wsCode.Select
Application.CutCopyMode = False
Range("B1").Select
Selection.End(xlDown).Select
ActiveWorkbook.Names.Add Name:="Last_Descript", _
RefersToR1C1:=ActiveCell

Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)).Copy _
Destination:=Sheets("Temp").Range("A2")

For Each ws In Worksheets
If Left(ws.Name, 6) = "Period" Then 'Is data sheet
ws.Select
Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)).Copy _
Destination:=Sheets("Temp").Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0)
End If
Next ws

Sheets("Temp").Select
Range("A1").Select

Set rngSelect = Range(Selection, Selection.End(xlDown))

rngSelect.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("B1"), _
Unique:=True

Range("C2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-1],'Code Table'!R2C1:Last_Descript,2,FALSE)"

Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste

Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Set rngCodeDescr = Range(Cells(2, 3), _
Cells(Rows.Count, 3).End(xlUp))
rngCodeDescr.Select

For Each c In rngCodeDescr

If IsError(c) Then

strTemp = c.Offset(0, -1)
strInput = InputBox("Code " & strTemp & _
" does not have a description " & Chr(10) _
& "Please insert the description")
If strInput = "" Then
MsgBox "Description not entered" & _
Chr(13) & "Processing terminated"
End
End If
c.Value = strInput
'Add to code Table
Range(c.Offset(0, -1), c).Copy _
Destination:=Sheets("Code Table"). _
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
Next c
End Sub

Hope it works well for you,

Regards,

OssieMac

 

[Joel]

the code siomplifies a lot if you use the wroksheet function SUMIF

Hi,

I decided to take this on and it became a marathon. However, try what I have
and see how it goes.

I'm sure that I shouldn't have to tell you this but I will anyway. Make sure
that you have a backup of your workbook.

I have assumed that your code table all of your data column headers start at
cell A1 on each sheet.

Also assumes that worksheet 'Summary' exists.

You will need to rename your data sheets to just Period1, Period2, Period3
etc. This is because I made it dynamic for the number of data sheets and I
have used the sheet names on the Summary. I didn't want to start extracting
part of the name because when you get past Period9 there is more characters
etc and I am sure you understand.

Run the macro from Sub Summary_Data and it calls the second procedure.

Also it adds a worksheet called Temp. You can either leave it in or delete
it if you don't want it.

For the missing codes, it requests that you enter them. If no entry then the
procedure terminates.

Missing codes are appended to the codes in Code Table.


Option Explicit
Dim wsCode As Worksheet 'Code Table W'sheet
Dim rngCode As Range 'Code Table code Column
Dim rngData As Range 'Data in Data W'Sheets
Dim ws As Worksheet 'Each data W'sheet
Dim wsSumm As Worksheet 'Summary W'sheet
Dim rngSummCode As Range 'Codes in summary W'sheet
Dim cCode As Range 'Each cell in rngCode
Dim dCode As Range 'Each cell in rngData
Dim colNumb As Single 'Column # for summary headers
Dim colName As String 'Summary W'Sht Column names
Dim cellFound As Range 'Found cell in summary W'Sheet
Dim rngHeadSumm As Range 'Column headers in Summary W'Sht
Dim cHead As Range 'Each col header in Summary W'Sht
Dim rngSelect 'Selected range
Dim rngCodeDescr 'Range of descriptions
Dim c As Range 'each cell in rngSelect
Dim strTemp 'Code holder
Dim strInput 'Input box data
Dim rowNumb 'No of rows of data in summary

Sub Summary_Data()

Set wsCode = Worksheets("Code Table")

'Update Code Table from existing Code Table
'plus any new codes found in data.
Call Temp_Code_Table

With wsCode
Set rngCode = Range(.Cells(2, 1), _
.Cells(Rows.Count, 1).End(xlUp))
End With

'Create Summary sheet column headers from data sht names
Set wsSumm = Sheets("Summary")

With wsSumm
.Cells.Clear
.Cells(1, 1) = "Code"
.Cells(1, 2) = "Description"
colNumb = 2 'Initialize column number for headers
For Each ws In Worksheets
If Left(ws.Name, 6) = "Period" Then
colNumb = colNumb + 1
colName = ws.Name
.Cells(1, colNumb) = colName 'Col Head = Sht name
End If
Next ws
colNumb = colNumb + 1
.Cells(1, colNumb) = "Total"
Set rngHeadSumm = Range(.Cells(1, 1), _
.Cells(1, Columns.Count).End(xlToLeft))
End With

Sheets("Temp").Select
Range(Cells(2, 2), Cells(Rows.Count, 3).End(xlUp)).Copy _
Destination:=Sheets("Summary").Range("A2")


For Each cCode In rngCode
For Each ws In Worksheets
If Left(ws.Name, 6) = "Period" Then 'Is data sheet
With ws
Set rngData = Range(.Cells(2, 1), _
.Cells(Rows.Count, 1).End(xlUp))
End With
'Find column number matching data sht name
For Each cHead In rngHeadSumm
If cHead = ws.Name Then
colNumb = cHead.Column
Exit For
End If
Next cHead

ws.Select
rngData.Select

For Each dCode In rngData

If dCode = cCode Then 'Found in code table
'Find Summary col numb = data sht name
With wsSumm
Set rngSummCode = Range(.Cells(2, 1), _
.Cells(Rows.Count, 1).End(xlUp))
Set cellFound = rngSummCode.Find(What:=dCode, _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not cellFound Is Nothing Then 'Found
.Cells(cellFound.Row, colNumb) = _
.Cells(cellFound.Row, colNumb) _
+ dCode.Offset(0, 1)
End If
End With

End If
Next dCode

End If
Next ws
Next cCode

'Insert formulas for Totals
Sheets("Summary").Select
rowNumb = Cells(Rows.Count, 1).End(xlUp).Row
Rows("1:1").Select
Selection.Find(What:="Total", _
After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False).Activate

'Insert row totals
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "=SUM(RC3:RC[-1])"

ActiveCell.Copy _
Destination:=Range(ActiveCell, _
Cells(rowNumb, ActiveCell.Column))

'Insert column totals
Cells(rowNumb, ActiveCell.Column).Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "=SUM(R2C:R[-1]C)"

ActiveCell.Copy _
Destination:=Range(ActiveCell, _
Cells(rowNumb + 1, 3))

Cells(rowNumb + 1, 1) = "Totals"

Cells.Columns.AutoFit

End Sub


Sub Temp_Code_Table()

On Error Resume Next
Sheets("Temp").Select
On Error GoTo 0

'If sheet temp not already exists then add
If ActiveSheet.Name <> "Temp" Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Temp"
End If
Cells.Clear
Range("A1") = "Code"

wsCode.Select
Application.CutCopyMode = False
Range("B1").Select
Selection.End(xlDown).Select
ActiveWorkbook.Names.Add Name:="Last_Descript", _
RefersToR1C1:=ActiveCell

Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)).Copy _
Destination:=Sheets("Temp").Range("A2")

For Each ws In Worksheets
If Left(ws.Name, 6) = "Period" Then 'Is data sheet
ws.Select
Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)).Copy _
Destination:=Sheets("Temp").Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0)
End If
Next ws

Sheets("Temp").Select
Range("A1").Select

Set rngSelect = Range(Selection, Selection.End(xlDown))

rngSelect.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("B1"), _
Unique:=True

Range("C2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-1],'Code Table'!R2C1:Last_Descript,2,FALSE)"

Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste

Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Set rngCodeDescr = Range(Cells(2, 3), _
Cells(Rows.Count, 3).End(xlUp))
rngCodeDescr.Select

For Each c In rngCodeDescr

If IsError(c) Then

strTemp = c.Offset(0, -1)
strInput = InputBox("Code " & strTemp & _
" does not have a description " & Chr(10) _
& "Please insert the description")
If strInput = "" Then
MsgBox "Description not entered" & _
Chr(13) & "Processing terminated"
End
End If
c.Value = strInput
'Add to code Table
Range(c.Offset(0, -1), c).Copy _
Destination:=Sheets("Code Table"). _
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
Next c
End Sub

Hope it works well for you,

Regards,

OssieMac

 

[Zone]

Celeste, since new codes can appear in the Period tables that are not in the
Code Table, it seems it would be easier to first add new codes and their
descriptions to the Code Table. If the answers to my last 2 questions were
Yes, this should work. I didn't know whether you have a source for the code
descriptions, so I just included an inputbox for them. Paste this code in a
standard module and run it. It if works to add the new codes and their
descriptions, then we'll proceed. James

Sub CreateSummary()
Dim k As Long, Sht As Integer
Dim newDesc As String
'check that codes are in Code Table
Worksheets(1).Activate
For Sht = 2 To 3
With Worksheets(Sht)
For k = 3 To .Cells(3, "a").End(xlDown).Row
If Not FindCode(.Cells(k, "a")) Then
newDesc = InputBox("Enter description " _
& " for Code " & .Cells(k, "a"))
If newDesc = "" Then
Exit Sub
Else
Cells(3, "a").End(xlDown).Offset(1) _
= .Cells(k, "a")
Cells(3, "b").End(xlDown).Offset(1) _
= newDesc
End If
End If
Next k
End With
Next Sht
End Sub

Function FindCode(myCode) As Boolean
Dim c As Range
FindCode = False
Set c = Columns(1).Find(myCode, _
Lookat:=xlWhole, LookIn:=xlValues)
If Not c Is Nothing Then FindCode = True
End Function

 

[u473]

Thank you Joel for your answer. I am very appreciative of this
brainwork and I am going to chew on it.
Answering the previous questions from Zone :
1. Are all the codes and their descriptions listed in the Code Table
on Sheet 1?
That is one of the problem because new Codes will pop up in
Periods.
I was considering either being prompted and updating the Code
Table on the fly
or populating an Exception worksheet. either solution is fine.
2. Do all the tables begin in cell A1, with a heading row in row 1?
Yes
3. Will more periods be added ? No How many periods : 12

 

[u473]

Woowww !!! Thank you all of you. I am going to put this to test.
Celeste.

 

[u473]

Thank you for this beautiful programming demonstration. This complex
exercise did more for me
than going thru my collection of VBA books or filtering the postings
on the subject here,
like calling Excel functions etc... I will go back at it, again and
again until I master logic & syntax.
That being said and trying to refine the application further,
1. How would I implement at the beginning of the run, whether to be
prompted for unknown codes or
or have the program simply write them to an Exception table, thru
your Temp_Code_Table()

2. Variation : With an additional table of Codes that are no longer
allowed to be used.
How would I write those Periods attemps to use them and the
unknown or new codes to the Exception Table ?

3. In range definition, what drives using either End(xlUp) or
End(xlDown) ?
Thank you again,
Celeste

 

[u473]

Precisions : For my grasping of VBA, I would like to see both versions
Version1 : This cycle would have Period1 and Period2, in the Summary
Table.
each following cycle would add one Period, to a
maximum of 12 Periods.

Version2 : A predefined Summary Table of 12 Periods.

Headers on 2 rows. Data starting in row 3 for all tables.
Thank you again,
Celeste

 

[Zone]

Okay, Celeste, here is my attempt. It's only concerned with the 2 periods
that currently exist, so of course it will need to be tweeked as additional
periods are added. Note that I have changed my original code, including the
function. Let me know how it works for you! James

Sub CreateSummary()
Dim k As Long, Sht As Integer, TableBtm As Long
Dim j As Integer, TableRt As Integer
Dim newDesc As String, ToRow As Long
'check that codes are in Code Table
Worksheets(1).Activate
For Sht = 2 To 3
With Worksheets(Sht)
TableBtm = [a3].End(xlDown).Row
For k = 3 To TableBtm
If FindCode(.Cells(k, "a")) = 0 Then
newDesc = InputBox("Enter description " _
& " for Code " & .Cells(k, "a"))
If newDesc = "" Then
Exit Sub
Else
TableBtm = TableBtm + 1
Cells(TableBtm, "a") = .Cells(k, "a")
Cells(TableBtm, "b") = newDesc
End If
End If
Next k
End With
Next Sht
'sort Code Table
Range("a3:b" & TableBtm).Sort key1:=Range("a3"), _
Order1:=xlAscending, header:=xlNo
'copy Code Table to Summary Table
Worksheets(4).Cells.Clear
TableRt = [a1].End(xlToRight).Column
Range(Cells(1, 1), Cells(TableRt, TableBtm)).Copy _
Destination:=Worksheets(4).[a1]
Worksheets(4).Activate
'set up summary table
Columns(2).AutoFit
[a1] = "Summary Table"
[c2] = "Period 1"
[d2] = "Period 2"
[e2] = "Total"
For k = 3 To TableBtm
For j = 3 To 4
Cells(k, j) = 0
Next j
Cells(k, 5) = "=sum(c" & k & ":d" & k & ")"
Next k
Cells(TableBtm + 2, 5) = "=sum(e3:e" & TableBtm & ")"
'get period information
For Sht = 2 To 3
With Worksheets(Sht)
For j = 3 To .Cells(3, "a").End(xlDown).Row
ToRow = FindCode(.Cells(j, "a"))
Cells(ToRow, Sht + 1) = _
Cells(ToRow, Sht + 1) + .Cells(j, "b")
Next j
End With
Next Sht
End Sub

Function FindCode(myCode) As Long
Dim c As Range
FindCode = 0
Set c = Columns(1).Find(myCode, _
lookat:=xlWhole, LookIn:=xlValues)
If Not c Is Nothing Then FindCode = c.Row
End Function