kroz
10-07-2012, 10:50 PM
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):
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
Thank you for your help.
P.S. If requested i can post the link to the other thread on the other site.
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):
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
Thank you for your help.
P.S. If requested i can post the link to the other thread on the other site.