Summarize data. VBA CODE

[pegbol]

.
.
Hello Champions,

I have 31 worksheets, each one named by one day of the month, 1, 2, 3,.....31. All the sheets have the same format.

What I pretend to do is summarize the range (B3:B40) of each sheet and take it into a master sheet called "Resumen" showing only unique values and how many times these values were repeated in the 31 worksheets.

I attached my example file.

Please masters!!!. Help me.

Thank you in advance for your kind assistance

regards,
Pedro
.
.

[pegbol]

.
.
Hello Masters,

I changed a little my request.

I included one more column called "Amount" to my 31 worksheets.
In the master sheet "Resumen", all the figures of column "Amount" will have to be added.

Enclosed is my example.

Thanks so much for your attention.

best regards,
Pedro
.
.

[xCav8r]

Perhaps someone smarter than I will respond, but in the meantime, could you rephrase your question? I downloaded your second attachment and read both of your posts, but I'm afraid I still don't understand what you'd like to do.

[Bob Phillips]

I included one more column called "Amount" to my 31 worksheets.
In the master sheet "Resumen", all the figures of column "Amount" will have to be added.

Hi Pedro,

How is it in Bolivia today?

Here is what you do.

On your resume sheet in cell C23, enter the formula

=SUMPRODUCT(COUNTIF(INDIRECT("'"&ROW(INDIRECT("1:31"))&"'!$B$3:$B$40"),$B23))

and in cell D23 enter

=SUMPRODUCT(SUMIF(INDIRECT("'"&ROW(INDIRECT("1:31"))&"'!$B$3:$B$40"),$B23,INDIRECT("'"&ROW(INDIRECT("1:31"))&"'!$E$3:$E$40")))

Then copy down across all appropriate rows.

Note that it assumes sheets 1 to 31 exists, it will give #REF error if one doesn't.

[pegbol]

.
.
xld,

Thank you so much for your kind reply and solution.

Appreciate your nice greeting.


I tried both formulas and they work excellent!!!!!!

I only have one problem:
The letters (P, A, etc.) for ID are only an example . An ID has the next format:
4248-15512
Considering that I have no control in the code of an ID, and consequently do not know the codes of all IDs that exist in the 31 worksheets. How can get only unique values column ID of all 31 worksheets in my resume sheet?.

xld, I would higly appreciate help me with this request.

Thanks so much Master for your valuable assistance.

kindest regards,
Pedro
.
.

[pegbol]

.

.

Please, any help

.

.

[Bob Phillips]

Please, any help

Off to bed. Will look again tomorrow before th cup final.

[pegbol]

.

.

OK. Good night
.
.

[Bob Phillips]

Morning again Pedro,

Here is some code to handle the id.s It consists of two parts. a module that populates the ID table from the data on the worksheets, and some event code to trigger it.

First, in the VBE IDE, add a new module, and paste this code in

Option Explicit
 
Public Const kResume As String = "Resumen"
 
Public Sub SetupIds()
Dim oWsResume As Worksheet
Dim Sh As Worksheet
Dim iLastRow As Long
Dim iNextRow As Long
Dim i As Long
Dim iID As Long
Dim sBaseFormula As String
Dim sFormula As String
Set oWsResume = Worksheets(kResume)
iNextRow = 1
oWsResume.Activate
'extract all unique ids from each worksheet
For Each Sh In ThisWorkbook.Worksheets
If Sh.Name <> oWsResume.Name Then
Sh.Range("B2:B40").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("AA" & iNextRow), _
Unique:=True
iNextRow = oWsResume.Cells(Rows.Count, "AA").End(xlUp).Row + 1
End If
Next Sh'now filter the amalgamated ids for uniqueness
oWsResume.Range("AA1:AA" & iNextRow - 1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("AB1"), _
Unique:=True
'clear the id table
With Range("B23:D2000")
.ClearContents
.Interior.ColorIndex = xlNone
.Borders(xlLeft).LineStyle = xlNone
.Borders(xlRight).LineStyle = xlNone
.Borders(xlTop).LineStyle = xlNone
.Borders(xlBottom).LineStyle = xlNone
End With
'setup the table with unique ids
iID = 22
For i = 1 To Cells(Rows.Count, "AB").End(xlUp).Row
If Cells(i, "AB") <> "ID" And Cells(i, "AB") <> "" Then
iID = iID + 1
Cells(iID, "B").Value = Cells(i, "AB").Value
End If
Next i
'add formulas
sBaseFormula = _
"=SUMPRODUCT(COUNTIF(INDIRECT(""'""&ROW(INDIRECT(""1:31""))&""'!$B$3:$B$40""),$B23"
Range("C23").Formula = sBaseFormula & "))"
Range("D23").Formula = "=SUMPRODUCT(SUMIF(INDIRECT(""'""&ROW(INDIRECT(""1:31""))&""'!$B$3:$B$40""),$B23" & _
",INDIRECT(""'""&ROW(INDIRECT(""1:31""))&""'!$E$3:$E$40"")))"
Range("C23:D23").AutoFill Destination:=Range("C23:D" & iID)
'format ID table
With Range("B23:D" & iID)
.Interior.ColorIndex = 36
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
'delete temporary lists
Columns("AA:AB").Delete
End Sub

and then add this code to the ThisWorkbook code module.

Option Explicit
 
Private Sub Workbook_Open()
SetupIds
End Sub
 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim oWsThis As Worksheet
On Error GoTo ws_exit:
Application.EnableEvents = False
If Sh.Name <> kResume Then
Set oWsThis = Sh
If Not Intersect(Target, Sh.Range("B3:B40")) Is Nothing Then
SetupIds
Sh.Activate
End If
End If
ws_exit:
Application.EnableEvents = True
End Sub

Save and test.

[pegbol]

.
.
xld,

Yes!!!!!!. You made it, Master.

The code works wonderfully OK.

I am completely grateful for your valuable assistance.


Muchas, muchas, muchas gracias, y que tengas un maravilloso fin de semana.

un afectuoso saludo desde La Paz,
Pedro


.
.

[Bob Phillips]

y que tengas un maravilloso fin de semana.

un afectuoso saludo desde La Paz,

Mi placer Pedro.

Tenga un buen fin de semana usted mismo, y saludos de Coyhaique.

Arsenal para la taza!!