PDA

View Full Version : [SOLVED] Summarize data. VBA CODE



pegbol
05-19-2005, 04:50 PM
.
.
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.:help

Thank you in advance for your kind assistance

regards,
Pedro
.
.

pegbol
05-19-2005, 05:23 PM
.
.
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.: pray2: :help

best regards,
Pedro
.
.

xCav8r
05-19-2005, 09:30 PM
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
05-20-2005, 02:40 AM
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
05-20-2005, 08:59 AM
.
.
xld,

Thank you so much for your kind reply and solution.

Appreciate your nice greeting.


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

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. :bow:

Thanks so much Master for your valuable assistance.

kindest regards,
Pedro
.
.

pegbol
05-20-2005, 12:25 PM
.

.

Please, any help :help

.

.

Bob Phillips
05-20-2005, 04:49 PM
Please, any help :help

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

pegbol
05-20-2005, 07:05 PM
.

.

OK. Good night :hi:
.
.

Bob Phillips
05-21-2005, 06:32 AM
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
05-21-2005, 07:23 AM
.
.
xld,

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

The code works wonderfully OK. :thumb :bow:

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

:beerchug:
.
.

Bob Phillips
05-21-2005, 07:39 AM
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!!