PDA

View Full Version : [SOLVED] Help with date macro



mercmannick
07-11-2005, 01:51 PM
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
07-11-2005, 01:52 PM
Late 1 Week :67Late 2 Weeks :100Late 3 Weeks : 109Late 4 Weeks :354CNF & 55 Deleted :317




is what it ouputs

Merc

mercmannick
07-11-2005, 01:57 PM
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
07-11-2005, 02:03 PM
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
07-11-2005, 02:06 PM
here it is thanks xld

Merc

mercmannick
07-11-2005, 02:10 PM
oops sorry forgot to zip

Bob Phillips
07-11-2005, 05:13 PM
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
07-12-2005, 11:43 AM
xld

superb m8 thnx

Tryed it today at work ,works a treat

Merc