Solved: VBA table summarize

Hey guys,

I'm posting this hoping that there are some of you that read this forum and not another forum where i got no reply for this post (well, no helpful reply).

I have a schedule table for my team and i added some code to summarize the activity for each week. The code is laggy but it does get the job done.

What i want is to extend the code so that it would summarize the activity for each month.

That being said, here's a short description of my file (the code is below):

Table head:
- on the first three rows i'm storing dates (to make it look better i've merged the columns in months and weeks)
- the next rows (up to row 500) contain data.

Each working day is marked with 1 in a cell.

The code (the code does some extra things, as in summarize the days on projects and grouping people that worked on the same projects):

[VBA]
Sub SyntheseActivite()
Dim onecell As Range, ar As Range
Dim arl As Long
Dim vv As String, cini As String, sem As String, a1 As String, cfin As String
Dim ri, RowT, EndR As Integer, mlt As Integer
Dim rFormula As Variant
Sheet2.Cells.Clear
Worksheets("DATA").Select
sem = "S" & Application.InputBox(prompt:="Input week number", Title:="Week number")
arl = WorksheetFunction.Match(sem, Worksheets("DATA").Range("I29:GJ29"), 0) + 8
ri = 1
mlt = 1
p = 49
With Worksheets("DATA")
For Each onecell In Columns(arl).Cells
If WorksheetFunction.Sum(Range(Cells(onecell.Row, arl), Cells(onecell.Row, arl + 4))) > 0 Then
If ri > 2 Then
.Range(Cells(onecell.Row, "A"), Cells(onecell.Row, "G")).Copy Destination:=Worksheets("Synthese Activite").Range("A" & ri)
Sheets("Synthese Activite").Range("J" & ri).FormulaR1C1 = "=SUM(DATA!R[" & onecell.Row - ri & "]C[" & arl - 10 & "]:R[" & onecell.Row - ri & "]C[" & arl - 6 & "])"
End If
ri = ri + 1
End If
Next
End With
Worksheets("Synthese Activite").Select
For Each onecell In Range("E3:E" & Range("E65536").End(xlUp).Row)
cfin = Cells(onecell.Row, 5).Value
a1 = "--($B$1:$B" & onecell.Row & "=$B" & onecell.Row & ")" & ",--($E$1:$E" & onecell.Row & "=$E" & onecell.Row & ")"
rFormula = Evaluate("=SUMPRODUCT(" & a1 & ")< 2")
If Not (rFormula) Then
vv = Cells(onecell.Row, "E").Value
RowT = WorksheetFunction.Match(vv, Worksheets("Synthese Activite").Range("E1:E" & onecell.Row), 0)
Cells(RowT, "G").Value = Cells(RowT, "G").Value & ", " & Cells(onecell.Row, "G").Value
Cells(RowT, 10).Value = "=" & Cells(RowT, 10).Value & "+" & Cells(onecell.Row, 10).Value
Rows(onecell.Row).EntireRow.Delete
mlt = mlt + 1
End If
Next
End Sub
[/VBA]

Thank you for your help.

P.S. If requested i can post the link to the other thread on the other site.

Post that link so anyone can read the answers if they want and not go down the same path.

You would also do better to post the workbook.

The other thread:

http://www.mrexcel.com/forum/excel-q...ml#post3284929

I've attached a sample of the file. After doing the summarize I put the data in format - you can ignore the second part of the code.

Crikey, that is slow. This is much faster

[VBA]Sub SyntheseActivite()
Dim onecell As Range, ar As Range
Dim arl As Long
Dim vv As String, cini As String, sem As String, a1 As String, cfin As String
Dim ri, RowT, EndR As Integer, mlt As Integer
Dim rFormula As Variant

Application.ScreenUpdating = False

Worksheets("Synthese Activite").Cells.Clear

With Worksheets("DATA")

sem = Application.InputBox(prompt:="Input week number", Title:="Week number")
If sem = "False" Then Exit Sub
arl = WorksheetFunction.Match("S" & sem, .Range("I29:GJ29"), 0) + 8
ri = 1
mlt = 1
p = 49

For Each onecell In .Range(.Cells(32, arl), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, arl))

If WorksheetFunction.Sum(onecell.Resize(1, 5)) > 0 Then

.Range(.Cells(onecell.Row, "A"), .Cells(onecell.Row, "G")).Copy _
Destination:=Worksheets("Synthese Activite").Range("A" & ri)
Sheets("Synthese Activite").Range("J" & ri).FormulaR1C1 = _
"=SUM(DATA!R[" & onecell.Row - ri & "]C[" & arl - 10 & "]:R[" & onecell.Row - ri & "]C[" & arl - 6 & "])"

ri = ri + 1
End If
Next
End With

With Worksheets("Synthese Activite")

For Each onecell In .Range("E1:E" & .Cells(.Rows.Count, "E").End(xlUp).Row)

cfin = .Cells(onecell.Row, "E").Value
a1 = "$B$1:$B" & onecell.Row & ",$B" & onecell.Row & _
",$E$1:$E" & onecell.Row & ",$E" & onecell.Row
If Application.CountIfs(.Range("B5:B" & onecell.Row), .Range("B" & onecell.Row), _
.Range("E5:E" & onecell.Row), .Range("E" & onecell.Row)) > 1 Then

vv = .Cells(onecell.Row, "E").Value
RowT = WorksheetFunction.Match(vv, .Range("E1:E" & onecell.Row), 0)
.Cells(RowT, "G").Value = .Cells(RowT, "G").Value & ", " & .Cells(onecell.Row, "G").Value
.Cells(RowT, 10).Value = "=" & .Cells(RowT, 10).Value & "+" & .Cells(onecell.Row, 10).Value
.Rows(onecell.Row).EntireRow.Delete
mlt = mlt + 1
End If
Next

.Cells.Validation.Delete
.Cells.ClearFormats
.ClearCircles
.Columns("A:H").AutoFit
.Columns("C:C").Hidden = True
.Rows("1:2").Insert

With .Range("B1:H1")

.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
.Value = "Synthese Activite Calculs RTR DIEC"
.Font.Name = "Calibri"
.Font.Size = 16
.Font.Bold = True
End With

With .Range("A2:J2")

.Value = Array("Perimetre", "Projet", "", "Jalon", "Calcul", "Etat", "Resource", "", "", "Nb. Jours")

With .Font

.Bold = True
.Color = -16764007
.TintAndShade = 0
End With

.AutoFilter
End With

With .Range("G2:I2")

.MergeCells = True
.HorizontalAlignment = xlCenter
End With

With .Range("A3:L" & r1 + 2).Font

.Name = "Calibri"
.Size = 11
.Bold = True
End With

With .Range("C1:C500")

.Value = .Value
End With
End With

Application.ScreenUpdating = True
End Sub[/VBA]

That is much faster, thank you. Ok, now that the slowness of the code is solved, i come back to the second issue:

Quote:

---

What i want is to extend the code so that it would summarize the activity for each month.

---

Any idea on how i could tell it to pull an monthly overview? I can't use the months row since it's merged and i can't use a fixed number of days since ..well, since months are different :)

Thank you for the help!

[VBA]Option Explicit

Public Sub WeeklySummary()
Dim arl As Long
Dim sem As String

sem = Application.InputBox(prompt:="Input week number", Title:="Week number")
If sem <> "False" Then

arl = WorksheetFunction.Match("S" & sem, Worksheets("DATA").Range("I29:GJ29"), 0) + 8
Call SyntheseActivite(arl, 5)
End If
End Sub

Public Sub MonthlySummary()
Dim arl As Long
Dim cell As Range

Set cell = Application.InputBox(prompt:="Select the month cell in row 28 using the mouse", Title:="Month", Type:=8)
If Not cell Is Nothing Then

Call SyntheseActivite(cell.Column, Application.Evaluate("SUMPRODUCT(--(MONTH(30:30)=" & Month(cell.Offset(2).Value) & "))"))
End If
End Sub

Sub SyntheseActivite(ByVal col As Long, ByVal days As Long)
Dim onecell As Range, ar As Range
Dim vv As String, cini As String, a1 As String, cfin As String
Dim ri, RowT As Long, EndR As Long, mlt As Long
Dim rFormula As Variant

Application.ScreenUpdating = False

Worksheets("Synthese Activite").Cells.Clear

With Worksheets("DATA")
ri = 1
mlt = 1

For Each onecell In .Range(.Cells(32, col), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, col))

If WorksheetFunction.Sum(onecell.Resize(1, days)) > 0 Then

.Range(.Cells(onecell.Row, "A"), .Cells(onecell.Row, "G")).Copy _
Destination:=Worksheets("Synthese Activite").Range("A" & ri)
Sheets("Synthese Activite").Range("J" & ri).FormulaR1C1 = _
"=SUM(DATA!R[" & onecell.Row - ri & "]C" & col & ":R[" & onecell.Row - ri & "]C" & col + days - 1 & ")"

ri = ri + 1
End If
Next
End With

With Worksheets("Synthese Activite")

For Each onecell In .Range("E1:E" & .Cells(.Rows.Count, "E").End(xlUp).Row)

cfin = .Cells(onecell.Row, "E").Value
a1 = "$B$1:$B" & onecell.Row & ",$B" & onecell.Row & _
",$E$1:$E" & onecell.Row & ",$E" & onecell.Row
If Application.CountIfs(.Range("B5:B" & onecell.Row), .Range("B" & onecell.Row), _
.Range("E5:E" & onecell.Row), .Range("E" & onecell.Row)) > 1 Then

vv = .Cells(onecell.Row, "E").Value
RowT = WorksheetFunction.Match(vv, .Range("E1:E" & onecell.Row), 0)
.Cells(RowT, "G").Value = .Cells(RowT, "G").Value & ", " & .Cells(onecell.Row, "G").Value
.Cells(RowT, "J").Value = "=" & .Cells(RowT, "J").Value & "+" & .Cells(onecell.Row, "J").Value
.Rows(onecell.Row).EntireRow.Delete
mlt = mlt + 1
End If
Next

.Cells.Validation.Delete
.Cells.ClearFormats
.ClearCircles
.Columns("A:H").AutoFit
.Columns("C:C").Hidden = True
.Rows("1:2").Insert

With .Range("B1:H1")

.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
.Value = "Synthese Activite Calculs RTR DIEC"
.Font.Name = "Calibri"
.Font.Size = 16
.Font.Bold = True
End With

With .Range("A2:J2")

.Value = Array("Perimetre", "Projet", "", "Jalon", "Calcul", "Etat", "Resource", "", "", "Nb. Jours")

With .Font

.Bold = True
.Color = -16764007
.TintAndShade = 0
End With

.AutoFilter
End With

With .Range("G2:I2")

.MergeCells = True
.HorizontalAlignment = xlCenter
End With

With .Range("A3:L" & ri + 2).Font

.Name = "Calibri"
.Size = 11
.Bold = True
End With

With .Range("C1:C500")

.Value = .Value
End With
End With

Application.ScreenUpdating = True
End Sub[/VBA]

You're the best! thank you