Help with date macro

[mercmannick]

hi peeps

2 of you peeps were kind enough to write a bit of code for me

Sub ToughMacroa()
' Procedure : ToughMacro
' DateTime : 7/8/2005 13:11
' Author :
Application.ScreenUpdating = False
Dim iRow As Long
Dim iLastRow As Long
Dim iSheetCount As Long
Dim iCountCurrentWeek As Long
Dim iCount1to2Week As Long
Dim iCount2to3Week As Long
Dim iCount3toAll As Long
Dim cNotIncluded As Long
Dim rngToSort As Range
iLastRow = Range("B8").End(xlDown).Row
For iRow = iLastRow To 8 Step -1
If Cells(iRow, Asc("O") - 64).Value = "CNF" Or _
Cells(iRow, "B").Value Like "55*" Then
Rows(iRow).Delete
Else
With Cells(iRow, "E")
.Value = DateValue(Replace(.Value, ".", "/"))
If .Value >= Date And .Value <= (Date + 6) Then
iCountCurrentWeek = iCountCurrentWeek + 1 'should be 1 week from today count of rows
ElseIf .Value >= (Date + 7) And .Value <= Date + 13 Then
iCount1to2Week = iCount1to2Week + 1 'should be upto 2 wks from today
ElseIf .Value >= (Date + 14) And .Value <= Date + 20 Then
iCount2to3Week = iCount2to3Week + 1 ' should be upto 3 wks from today
ElseIf .Value >= (Date + 21) Then
iCount3toAll = iCount3toAll + 1 ' should be remaining count
Else
cNotIncluded = cNotIncluded + 1
End If
End With
End If
Next iRow
Range("A1:B5").Activate
Selection.Interior.ColorIndex = 38
Selection.Font.Bold = True
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
Columns("A:A").ColumnWidth = 22.71
End With
Range("A1").Value = "Late 1 Week :": Range("B1").Value = iCountCurrentWeek
Range("A2").Value = "Late 2 Weeks :": Range("B2").Value = iCount1to2Week
Range("A3").Value = "Late 3 Weeks : ": Range("B3").Value = iCount2to3Week
Range("A4").Value = "Late 4 Weeks :": Range("B4").Value = iCount3toAll
Range("A5").Value = "CNF & 55 Deleted :": Range("B5").Value = cNotIncluded
MsgBox "Total Count " & vbCrLf & _
"==============================" & vbNewLine & _
"Late 1 Weeks : " & iCountCurrentWeek & vbCrLf & _
"Late 2 Weeks : " & iCount1to2Week & vbCrLf & _
"Late 3 Weeks : " & iCount2to3Week & vbCrLf & _
"Late 4 weeks + " & iCount3toAll & vbNewLine & _
"No CNF Deleted : " & cNotIncluded, , "Weekly Counts Of Late To Finish Date "
Application.ScreenUpdating = True
End Sub

but it seems to count the dates wrongly

can someone point me or show me how this is going wrong
thanks

Merc

[mercmannick]

Late 1 Week :67Late 2 Weeks :100Late 3 Weeks : 109Late 4 Weeks :354CNF & 55 Deleted :317




is what it ouputs

Merc

[mercmannick]

from todays date to a week late should be 44
2 weeks late should be 18
3 wks 5
and 4 wks + should be 250

Can anyone one help me

Merc

[Bob Phillips]

from todays date to a week late should be 44
2 weeks late should be 18
3 wks 5
and 4 wks + should be 250

Can anyone one help me

Merc

Post the book?

[mercmannick]

here it is thanks xld

Merc

[mercmannick]

oops sorry forgot to zip

[Bob Phillips]

oops sorry forgot to zip

How about this. Not quite the same numbers as you, but I am testing 1 day later.

Sub ToughMacroa()
' Procedure : ToughMacro
     ' DateTime : 7/8/2005 13:11
     ' Author : MR Excel
Application.ScreenUpdating = False
Dim iRow As Long
    Dim iLastRow As Long
    Dim iSheetCount As Long
    Dim iCountCurrentWeek As Long
    Dim iCount1to2Week As Long
    Dim iCount2to3Week As Long
    Dim iCount3toAll As Long
    Dim cNotIncluded As Long
    Dim cDeleted As Long
    Dim rngToSort As Range
iLastRow = Range("B8").End(xlDown).Row
    For iRow = iLastRow To 8 Step -1
        If Cells(iRow, Asc("O") - 64).Value = "CNF" Or _
        Cells(iRow, "B").Value Like "55*" Then
            Rows(iRow).Delete
            cDeleted = cDeleted + 1
        Else
            With Cells(iRow, "E")
                .Value = DateValue(Replace(.Value, ".", "/"))
                If .Value < Date And .Value >= (Date - 7) Then
                    iCountCurrentWeek = iCountCurrentWeek + 1
                    .Offset(0, -4).Value = 1
                ElseIf .Value <= (Date - 8) And .Value >= Date - 14 Then
                    .Offset(0, -4).Value = 2
                    iCount1to2Week = iCount1to2Week + 1
                ElseIf .Value <= (Date - 15) And .Value >= Date - 21 Then
                    .Offset(0, -4).Value = 3
                    iCount2to3Week = iCount2to3Week + 1
                ElseIf .Value <= (Date - 22) Then
                    iCount3toAll = iCount3toAll + 1
                    .Offset(0, -4).Value = 4
                Else
                    cNotIncluded = cNotIncluded + 1
                End If
            End With
        End If
    Next iRow
With Range("A1:B5")
        .Interior.ColorIndex = 38
        .Font.Bold = True
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThick
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThick
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThick
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThick
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThick
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlThick
            .ColorIndex = xlAutomatic
            Columns("A:A").ColumnWidth = 22.71
        End With
    End With
Range("A1").Value = "Late 1 Week :": Range("B1").Value = iCountCurrentWeek
    Range("A2").Value = "Late 2 Weeks :": Range("B2").Value = iCount1to2Week
    Range("A3").Value = "Late 3 Weeks : ": Range("B3").Value = iCount2to3Week
    Range("A4").Value = "Late 4 Weeks :": Range("B4").Value = iCount3toAll
    Range("A5").Value = "CNF & 55 Deleted :": Range("B5").Value = cDeleted
Application.ScreenUpdating = True
End Sub

[mercmannick]

xld

superb m8 thnx

Tryed it today at work ,works a treat

Merc