selecting data from a database

[Roy Gudgeon]

I'll try my best to explain what i I want to do....

I have a databse that contains a list of times recorded by athletes over
various distances.

I would like ot be able to run a macro that compiles a report by selecting
personal best times by athletes name for the various distances. the database
is continually added to, athletes times are constantly updated so refencing
specific cells is not feasible.

I currently sort the database by name, distance, best time for that distance
so I can see an athletes history but need a method to extract the best times
for each discipline

 

[Don Guillett]

You could probably use a sumproduct or sum(if array formula for this.

If desired, send your file to my address below. I will only look if:
1. You send a copy of this message on an inserted sheet
2. You give me the newsgroup and the subject line
3. You send a clear explanation of what you want
4. You send before/after examples and expected results.

 

[Fred Smith]

This looks like a perfect application for a Pivot Table. Here's a primer on
them: http://www.cpearson.com/excel/pivots.htm

Regards,
Fred

 

[JLatham]

I agree that it's probably something that a Pivot Table will probably deal
with well (although I haven't tried setting one up for your situation).
But since you asked for a macro, here you go (and it may give you some
appreciation for the work that a Pivot Table does at times <grin>):

Sub ReportPersonalBests()
'change these constants
'to tailor to your
'workbook and worksheets
'sheet with all entries on it
Const dbSheetName = "Sheet1"
'column with names in it
Const nameCol = "A"
'column with events listed
Const eventCol = "B"
'column with times in it
Const timeCol = "C"
'name of sheet to place
'results onto
Const pbSheetName = "Sheet2"
'end of user definable values
'
Dim lastRow As Long
Dim theAthletes() As String
Dim theEvents() As String
Dim ALC As Integer ' loop counter
Dim ELC As Integer ' loop counter
Dim pbTime As Variant
Dim dbSheet As Worksheet
Dim pbSheet As Worksheet
Dim namesList As Range
Dim anyName As Range
Dim foundFlag As Boolean

'assumes database sheet has
'labels in row 1
Set dbSheet = ThisWorkbook.Worksheets(dbSheetName)
lastRow = dbSheet.Range(nameCol & Rows.Count). _
End(xlUp).Row
If lastRow < 2 Then
'no entries in name column
MsgBox "No data to process, quitting"
Set dbSheet = Nothing
Exit Sub
End If
Set namesList = _
dbSheet.Range(nameCol & "2:" & _
nameCol & lastRow)
'set up the personal best report
'sheet to receive the results
'clear any previous report
Set pbSheet = ThisWorkbook.Worksheets(pbSheetName)
pbSheet.Cells.Clear
pbSheet.Range("A1") = "Athlete"
pbSheet.Range("B1") = "Event"
pbSheet.Range("C1") = "Best Time"
'get list of unique names
'save in array theAthletes()
ReDim theAthletes(1 To 1)
For Each anyName In namesList
foundFlag = False
For ALC = LBound(theAthletes) To UBound(theAthletes)
If anyName = theAthletes(ALC) Then
foundFlag = True
Exit For
End If
Next ' end theAthletes loop
If Not foundFlag Then
'add name to the list
theAthletes(UBound(theAthletes)) = anyName
ReDim Preserve _
theAthletes(1 To UBound(theAthletes) + 1)
End If
Next ' end anyName loop
'remove the empty array element
If UBound(theAthletes) > 1 Then
ReDim Preserve _
theAthletes(1 To UBound(theAthletes) - 1)
End If
'now we have a list of the individual athletes
'we have to go through it one at a time and
'find what events they participated in
'after doing that, we then have to go back
'and find each entry for the athlete:event
'and pick up the minimum time for them
'to report.
For ALC = LBound(theAthletes) To UBound(theAthletes)
'build list of events they participated in
ReDim theEvents(1 To 1)
For Each anyName In namesList
If anyName = theAthletes(ALC) Then
foundFlag = False
For ELC = LBound(theEvents) To UBound(theEvents)
If dbSheet.Range(eventCol & anyName.Row) = _
theEvents(ELC) Then
'already in list
foundFlag = True
Exit For
End If
Next ' end ELC loop
If Not foundFlag Then
'add event to list
theEvents(UBound(theEvents)) = _
dbSheet.Range(eventCol & anyName.Row)
ReDim Preserve _
theEvents(1 To UBound(theEvents) + 1)
End If
End If
Next ' end anyName loop
If UBound(theEvents) > 1 Then
ReDim Preserve _
theEvents(1 To UBound(theEvents) - 1)
End If
'ready to match name:event to pick up best times
'set pbTime to very large value of 100
'this time is presumed to be hours, but in any
'case it must be larger than any possible
'actual reported time entry
For ELC = LBound(theEvents) To UBound(theEvents)
'ready to match name:event to pick up best times
'set pbTime to very large value of 100
'this time is presumed to be hours, but in any
'case it must be larger than any possible
'actual reported time entry
pbTime = 1000
For Each anyName In namesList
If anyName = theAthletes(ALC) And _
dbSheet.Range(eventCol & anyName.Row) = _
theEvents(ELC) Then
'name and event match, see if it's a
'new personal best time
If dbSheet.Range(timeCol & anyName.Row) < pbTime Then
pbTime = dbSheet.Range(timeCol & anyName.Row)
End If
End If
Next ' end anyName loop
lastRow = pbSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
pbSheet.Range("A" & lastRow) = theAthletes(ALC)
pbSheet.Range("B" & lastRow) = theEvents(ELC)
pbSheet.Range("C" & lastRow) = pbTime
Next ' end ELC loop
Next ' end of ALC loop
'all done, do housekeeping and inform user
Set namesList = Nothing
Set pbSheet = Nothing
Set dbSheet = Nothing
MsgBox "Personal Best List Compilation Completed"
End Sub