Solved: Number Based on Date

[bryVA]

Hello all,

I have a spreadsheet that has Dates in Column C and I need a macro to number Column B based on the Date. For example I have 08/01/2009 in the first five rows of Column C and 08/02/2009 in the next eight rows. I need the macro to number all 08/01/2009 1 - 5 and the 08/02/2009 1 - 8 in Column B.

I hope this makes sense.

Thanks for all your guys help.

-B

[GTO]

Greetings -B,

In a Standard Module:


Option Explicit

Sub AssignCounter()
Dim rngDates As Range
Dim rCell As Range

'// Presumes sheetname of "Sheet1" and a header row; change to suit.//
With ThisWorkbook.Worksheets("Sheet1")
Set rngDates = .Range("C2:C" & .Cells(Rows.Count, 3).End(xlUp).Row)
End With

For Each rCell In rngDates
If IsDate(rCell.Value) Then
rCell.Offset(, -1).Value = _
Application.CountIf( _
rngDates.Resize(rCell.Row - (rngDates.Row - 1)), rCell.Value)
End If
Next
End Sub


Hope that helps,

Mark

[rbrhodes]

Hi,


What it does:

- Checks for no rows
- Checks for single row
- Skips blank rows
- Numbers if not blank and in series


What it doesn't do:

- sort dates in order


Option Explicit
Sub NumDate()
Dim msg As Long
Dim cel As Range
Dim rng As Range
Dim mDate As Date
Dim countr As Long
Dim LastRow As Long
Dim FirstRow As Long
'//User Change
'Set first row of data
FirstRow = 1
'//End
'Clear old
Columns("B:B").ClearContents

'Init
countr = 1

'Get last row of data
LastRow = Range("C" & Rows.Count).End(xlUp).Row
'Check if data
If LastRow < FirstRow Then
msg = MsgBox("No data...", 48, "No dates")
GoTo endo
End If
If LastRow = FirstRow Then
If IsDate(Cells(FirstRow, 3)) Then
Cells(FirstRow, 2) = "1"
GoTo endo
Else
msg = MsgBox("No data...", 48, "No dates")
GoTo endo
End If
End If

'Where to look
Set rng = Range("C" & FirstRow + 1 & ":C" & LastRow)

'Check data
If IsDate(Cells(FirstRow, 3)) Then
'Get date
mDate = Cells(FirstRow, 3)
'Put first
Cells(FirstRow, 2) = "1"
'Init
countr = 2
End If

'Do all
For Each cel In rng
'Check data
If IsDate(Cells(cel.Row, 3)) Then
'Match?
If mDate = cel Then
'Put number
Cells(cel.Row, 2) = countr
'Incr
countr = countr + 1
Else
'No match
mDate = cel
'Reset
countr = 1
'Put number
Cells(cel.Row, 2) = countr
'Incr
countr = countr + 1
End If
End If
Next cel

endo:

'Cleanup
Set cel = Nothing
Set rng = Nothing

End Sub

[bryVA]

Thanks that is exactly what I needed.

You help is greatly appreciated.

-B