Add. New Macro

[MS]

Hi all,

I'd like insert in this "Macro"
the New Macro,
i must add. the number in "H" Column separate by day,
Date begin "B3"
The number to add. "H3"
The total in the Column "I3--------->"

Thanks.

Marcello

Sub Archivia()
Dim SH As Worksheet
Dim Name As String
Dim i As Long
Dim DataDoc As Date
Dim ConPag As Currency
Dim NPos As Currency
Dim NBan As Currency
Dim Rng As Range
Dim c As Range
Dim im As Double
Dim mi As Long
Dim nr As Long
Dim ia As Double
Dim ai As Long
Dim n As Long, r As Long

With Sheets("sheet3")

.Columns("A:E").ColumnWidth = 10
.Columns("F").ColumnWidth = 23
.Columns("G:H").ColumnWidth = 10.43
.Columns("I").ColumnWidth = 11.3
.Columns("L:O").ColumnWidth = 8.43
n = Worksheets.Count

.Range("A1").Value = Worksheets(n).Range("G13").Value

i = 2

.Range("A3:H2000").ClearContents
For Each SH In Worksheets
If SH.Name <> "Sheet3" Then

DataDoc = 0
For r = 18 To 25
If SH.Cells(r, 4).NumberFormat = "m/d/yyyy" Then
DataDoc = SH.Cells(r, 4)
Exit For
End If
Next
ConPag = 0
For r = 80 To 100
If SH.Cells(r, 4).NumberFormat = "#,##0.00" Then
ConPag = SH.Cells(r, 4)
Exit For
End If
Next
NPos = 0
For r = 35 To 35
If SH.Cells(r, 4) Then
NPos = SH.Cells(r, 4)
Exit For
End If
Next
NBan = 0
For r = 50 To 50
If SH.Cells(r, 5) Then
NBan = SH.Cells(r, 5)
Exit For
End If
Next

i = i + 1
.Cells(i, 1) = SH.Name
.Cells(i, 2) = DataDoc
.Cells(i, 3) = ConPag
.Cells(i, 7) = NPos
.Cells(i, 8) = NBan
End If
Next
Const sAddress As String = "D36"

For Each SH In ActiveWorkbook.Worksheets
With ActiveWorkbook.Sheets("Sheet3")
Set Rng = IIf(IsEmpty(.Range("F3")), .Range("F3"), _
Cells(Rows.Count, "F").End(xlUp)(2))
Rng.Value = SH.Range(sAddress).Value
End With
Next SH

With Worksheets("sheet3")

nr = .Range("B65536").End(xlUp).Row
Set Rng = .Range("B3:B" & nr)

mi = Month(.Range("B3").Value)
ai = Year(.Range("B3").Value)

For Each c In Rng

If Month(c.Value) = mi And Year(c.Value) = ai Then
im = im + c.Offset(0, 1).Value
Else
c.Offset(-1, 2).Value = im
im = c.Offset(0, 1).Value
mi = Month(c.Value)
End If

If Year(c.Value) = ai Then
ia = ia + c.Offset(0, 1).Value
Else
c.Offset(-1, 3).Value = ia
c.Offset(-1, 4).Value = "Totale anno: " & ai
ia = c.Offset(0, 1).Value
ai = Year(c.Value)
End If

Next

Set Rng = Nothing

.Range("D" & nr).Value = im
.Range("E" & nr).Value = ia
.Range("C" & nr + 1).Value = "Totale"
.Range("D" & nr + 1).Formula = "=SUM(D3" & nr & ")"

End With
End With

End Sub