Macro help inserting records by date sequence.

[Guest]

OS: MS XP
Excel: 2002

I have a table with six columns, Date, Name, Route, In, Comment and Out. I
need help with a macro to do the following:

1) The 1st date of each week for us starts on a Sunday and goes through the
following Saturday.
2) The table contains work assignments for bus drivers and may contain many
pieces of work in any one day.
3) Some days the drivers are not working.
4) An example of the Table is:

Date Name Route In Comment Out
5/19/08 Smith 210 10:15 Ride 14:15
5/23/08 Smith 215 12:25 Trip 14:45
5/23/08 Smith 217 13:15 Lunch 15:14
5/23/08 Smith 218 16:17 Lewes 18:15
5/24/08 Smith 220 19:34 Testing 20:15
5/20/08 Thomas 210 10:15 Ride 14:15
5/23/08 Thomas 215 12:25 Trip 14:45
5/23/08 Thomas 217 13:15 Lunch 15:14
5/23/08 Thomas 218 16:17 Lewes 18:15
5/26/08 Thomas 220 19:34 Testing 20:15
5/2608 Thomas 227 09:00 Lunch 16:17
5/2608 Thomas 301 12:15 Lewes 17:34
5/2608 Thomas 415 4:35 Testing 20:10

5) I need to insert one record for each day the driver isn’t working.
Either at the bottom of the table in in the proper date sequence.
6) In other words if there is a date missing in the 7 day sequence say from
05/18/08 through 05/26/08 then insert one record for the missing date.
7) At the beginning of each week we can insert the starting date of the
seven day sequence in Cell A1.
8) There are many drivers maybe 55.

Is it possible to do this with a macro???

Thanks in advance.

 

[Dave Peterson]

I'm not sure why you have to look at it on a week by week basis. Couldn't you
just look at all the dates--starting with the first (minimum date in column A)
and ending with the last (maximum date in column A)?

If that's ok, then this worked ok for me (it adds to the bottom of the data and
then sorts by name and date when finished):

Option Explicit
Sub testme01()

Dim CurWks As Worksheet
Dim TmpWks As Worksheet
Dim DateRng As Range
Dim MinDate As Date
Dim MaxDate As Date
Dim NameRng As Range
Dim dCtr As Long
Dim UniqueRng As Range
Dim myName As Range
Dim HowMany As Long
Dim DestCell As Range

Set CurWks = Worksheets("sheet1")
Set TmpWks = Worksheets.Add

With CurWks
Set DateRng = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))
Set NameRng = DateRng.Offset(0, 1)
End With

MinDate = Application.Min(DateRng)
MaxDate = Application.Max(DateRng)

'get a list of unique names in column A of the tmpwks
With NameRng
With .Offset(-1, 0).Resize(.Rows.Count + 1)
.AdvancedFilter _
action:=xlFilterCopy, _
copytorange:=TmpWks.Range("a1"), _
unique:=True
End With
End With

With TmpWks
Set UniqueRng = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))
End With

For Each myName In UniqueRng.Cells
For dCtr = MinDate To MaxDate
'=sumproduct(--(a2:ax=somedate),--(b2:bx="somename"))
HowMany = CurWks.Evaluate("sumproduct(--(" & DateRng.Address _
& "=" & dCtr & ")," _
& "--(" & NameRng.Address & "=" & Chr(34) _
& myName.Value & Chr(34) & "))")
If HowMany > 0 Then
'already there, skip it
Else
With CurWks
Set DestCell _
= .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
With DestCell
.NumberFormat = "mm/dd/yyyy"
.Value = dCtr
.Offset(0, 1).Value = myName.Value
.Offset(0, 2).Value = "No Route"
End With
End If
Next dCtr
Next myName

'sort the new list by name, then date
With CurWks
With .Range("a1:F" & DestCell.Row)
.Cells.Sort _
key1:=.Columns(2), order1:=xlAscending, _
key2:=.Columns(1), order2:=xlAscending, _
header:=xlYes
End With
End With

Application.DisplayAlerts = False
TmpWks.Delete
Application.DisplayAlerts = True

End Sub

Test it against a copy of your data--just in case.

ps. Your sample data used 2008. I bet that was a typo???

 

[Guest]

This looks great. I think I may be able to get it to work 100%.

1) We need to start off with a date which I can store in cell B2 of Sheet “S1
2) For example: The Date in cell B2 of Sheet “S1†is 9/9/07.
3) If the data is 9/9/07, 9/11/07, 9/12/07, 9/12/07/, 9/12/07, 9/14/07/
9/15/07.
4) The output should be: 9/9/07, 9/10/07 9/11/07, 9/12/07, 9/12/07/,
9/12/07, 9/13/07, 9/14/07/ 9/15/07.
5) With 9/10/07 and 9/13/07 being No Route.
6) If the date in Cell B2 of “S1†is 9/9/07.
7) If the data is 9/11/07, 9/11/07, 9/12/07, 9/12/07/, 9/12/07, 9/14/07/
9/15/07.
8) The output should be: 9/9/07, 9/10/07 9/11/07, 9/11/07, 9/12/07,
9/12/07/, 9/12/07, 9/13/07, 9/14/07/ 9/15/07.
9) With 9/9/07, 9/10/07 and 9/13/07 showing No Route.
PS 2008 was not a typo but that doesn't matter.

I am new with VBA and any help is appreciated.
Thanks in advance.

 

[Dave Peterson]

It's difficult to see your post when you copy from MSWord (I think). The double
quotes turn into some funny looking character.

But (I think) try changing these lines:

MinDate = Application.Min(DateRng)
MaxDate = Application.Max(DateRng)

to

MinDate = worksheets("s1").range("b2").value
MaxDate = mindate + 6

This looks great. I think I may be able to get it to work 100%.

1) We need to start off with a date which I can store in cell B2 of Sheet “S1
2) For example: The Date in cell B2 of Sheet “S1†is 9/9/07.
3) If the data is 9/9/07, 9/11/07, 9/12/07, 9/12/07/, 9/12/07, 9/14/07/
9/15/07.
4) The output should be: 9/9/07, 9/10/07 9/11/07, 9/12/07, 9/12/07/,
9/12/07, 9/13/07, 9/14/07/ 9/15/07.
5) With 9/10/07 and 9/13/07 being No Route.
6) If the date in Cell B2 of “S1†is 9/9/07.
7) If the data is 9/11/07, 9/11/07, 9/12/07, 9/12/07/, 9/12/07, 9/14/07/
9/15/07.
8) The output should be: 9/9/07, 9/10/07 9/11/07, 9/11/07, 9/12/07,
9/12/07/, 9/12/07, 9/13/07, 9/14/07/ 9/15/07.
9) With 9/9/07, 9/10/07 and 9/13/07 showing No Route.
PS 2008 was not a typo but that doesn't matter.

I am new with VBA and any help is appreciated.
Thanks in advance.

 

[Dave Peterson]

Try this instead:

MinDate = worksheets("s1").range("b2").value
mindate = mindate - weekday(mindate) + 1
MaxDate = mindate + 6