You might be getting this error because the cell being checked is
formatted as a number rather than General or Text. Try :-

Do Until wsSource.Cells(SourceRow, 1).Value = 0

Regards
BrianB
================================================== =======




"Thomas L. Wright" wrote in message ...
Dear Patrick,

Thank you for your newsgroup reply. Sorry about my error in column/row
terminology, but you did understand what I wanted to do. I haven't yet been
able to get things to work. I modified your dategrind routine to fit my file
addresses, but when I start to run I get error message 1004 at the line
beginning--Do Until wsSource.Cells(SourceRow, 1).Value = ""--. I thought
this might have to do with the second file you sent (adding commands on
toolbar?) so I tried to run it and got--error 424 object required-- (see
below).

I'm running this on a Macintosh, but I was getting the same errors on a pc.
There seem to be many hurdles to overcome before macros can be written
efficiently. I have successfully created several macros in microsoft word
and, since I am not a programmer, learned most of the tricks from recording
macros and seeing how the visual basic language described various keyboard
or menu actions. However, in excel many of the keyboard actions don't record
at all. I also couldn't get anything to work using commands given in the the
VBA help file. When I saw your code, I realized that there is a fundamental
level of programming missing from the help files.

Anyway, I appreciate your time. If there is any additional advice you can
give me to make the macro code below work, I would greatly appreciate it.

Sincerely, Tom Wright



Sub AddMenu()
Dim ctrlMain As CommandBarPopup
Dim ctrlItem As CommandBarControl
Dim ctrlSubItem As CommandBarButton

KillMenu
Set ctrlMain = _
CommandBars("Worksheet Menu Bar").Controls.Add _
(Type:=msoControlPopup, temporary:=True)
With ctrlMain
.Caption = "&Analysis"
Set ctrlItem = .Controls.Add(Type:=msoControlButton)
With ctrlItem
.Caption = "&Initialse Test" 'error 424 object required
.OnAction = "subInitialise"
End With
Set ctrlItem = _
.Controls.Add(Type:=msoControlPopup)
With ctrlItem
.Caption = "&Explore Test"
.BeginGroup = True
Set ctrlSubItem = .Controls.Add(Type:=msoControlButton)
With ctrlSubItem
.Caption = "Type &1"
.OnAction = "sub1"
End With
Set ctrlSubItem = _
.Controls.Add(Type:=msoControlButton)
With ctrlSubItem
.Caption = "Type &2"
.OnAction = "Sub2"
End With
End With
Set ctrlItem = .Controls.Add(Type:=msoControlButton)
With ctrlItem
.Caption = "&Plan Test"
.BeginGroup = True
.OnAction = "sub3"
End With
End With
End Sub
Sub KillMenu()
Dim cmdbar As CommandBar
On Error Resume Next
Set cmdbar = CommandBars("Worksheet Menu Bar")
cmdbar.Controls("&analysis").Delete
On Error GoTo 0
End Sub




'visual basic macro in excelFrom: Patrick Molloy
'Date Posted: 7/23/2003 1:03:00 AM


'proposed methodology:
'For each date in the source file, count existing items,
'adding or removing as required



Sub DateGrind()
Dim wsSource As Worksheet
Dim wsResults As Worksheet
Dim SourceRow As Long ' row pointer for Source book
Dim ResultRow As Long ' row pointer for Result book
Dim count As Long ' for counting the dates
Dim sourcedate As Date ' date to be tested
Dim eqctnum As Long ' lpc-b number

'Set wssource = Workbooks("Macintosh HD:Desktop
Folder:testsource.exl").ActiveSheet
'Set wsResults = Workbooks("Macintosh HD:Desktop
Folder:testresult.exl").ActiveSheet
' point to the relevant sheets
' note the data is as per the question
'Workbooks.Open FileName:= _
'"Macintosh HD:TLW/RSF kilauea book:tilt/seismicity:tilt/seismicity.excel:eq
count/tremor:testsource.exl"
'Workbooks.Open FileName:= _
'"Macintosh HD:TLW/RSF kilauea book:tilt/seismicity:tilt/seismicity.excel:eq
count/tremor:testresult.exl"
Windows("testsource.exl").Activate
Set wsSource = ActiveSheet
Range("d2").Select
Selection.Copy
eqctnum = Selection
Range("A2").Select
Selection.Copy
sourcedate = Selection
'Columns("A:A").Select
'Selection.Find(What:=sourcedate, After:=ActiveCell, LookIn:=xlFormulas, _
'LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
'MatchCase:=False).Activate

SourceRow = 2 ' row 1 is headers : date/lpc-b

Do Until wsSource.Cells(SourceRow, 1).Value = "" 'runtime error 1004

sourcedate = wsSource.Cells(SourceRow, 1).Value
eqctnum = _
wsSource.Cells(SourceRow, 1).Offset(0, 3).Value
count = 0
ResultRow = 1

Windows("testresult.exl").Activate
Set wsresult = ActiveSheet
Do Until wsResults.Cells(ResultRow, 1).Value = ""

If wsResults.Cells(ResultRow, 1).Value = sourcedate Then
count = count + 1
If count eqctnum Then
wsResults.Rows(ResultRow).Delete
Else
ResultRow = ResultRow + 1
End If
Else
ResultRow = ResultRow + 1
End If
Loop

Do While count < eqctnum
wsResults.Cells(ResultRow, 1).Value = sourcedate
ResultRow = ResultRow + 1
count = count + 1
Loop

SourceRow = SourceRow + 1
Loop
End Sub


'Basically the outer loop refers to each date in the
'source.
'the first inner loop counts the matching dates - when the
'count exceeds the requirement, dates are removed. the
'second inner loop adds dates if the count is less than
'the requirement.
'tested ok