How do I amend this code????

[hrprabhu]

Sub DataToBeSent()
On Error GoTo ErrorHandler
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim sState As String
Dim sClub As String
Dim s As String
Dim sSQL As String
Dim dDate As String
Dim i As Integer
Dim activeDir As String
Dim FileNum As Integer
 
 
activeDir = CurrentProject.Path
 
 
sSQL = "SELECT AFL.StateName, " _
    & "AFL.TeamName, " _
    & "AFL.PlayerSurname, " _
    & "AFL.EndOfSeason " _
    & "FROM AFL " _
    & "ORDER BY AFL.StateName, AFL.TeamName;"
 
'    Debug.Print sSQL
 
'XLSheetDump sSQL, activeDir & "\test.xls"
 
Set db = CurrentDb
Set rs = db.OpenRecordset(sSQL, dbOpenDynaset) 'dbOpenSnapshot dbOpenForwardOnly
With rs
    .MoveLast 'force error 3021 if no records
    .MoveFirst
 
'    sState = .Fields("StateName")
'    s = sState & vbCrLf
'    sClub = .Fields("TeamName")
'    s = s & sClub
 
    s = "State Name" & vbTab & "Club Name" & String(2, vbTab) & "End Of Season" & String(2, vbTab) & "Player Name" & vbCrLf
    Do Until .EOF
    s = s & .Fields("StateName") & String(2, vbTab) & Left(.Fields("TeamName") & Space(10), 10) & String(2, vbTab) & Left(.Fields("EndOfSeason") & Space(10), 10) & String(2, vbTab) & .Fields("PlayerSurname") & vbCrLf
    .MoveNext
    Loop
End With
SendToFile activeDir & "\OutputGetting.txt", s
rs.Close
 
GoTo ThatsIt
ErrorHandler:
    Select Case Err.Number
        Case 3021
        Case Else
            MsgBox "Problem with DataToBeSent()" & vbCrLf _
                 & "Error " & Err.Number & ": " & Err.Description
    End Select
ThatsIt:
If Not rs Is Nothing Then Set rs = Nothing
If Not db Is Nothing Then Set db = Nothing
End Sub
 

I want to modify this code. Please look at the attachments. I am sending the query to a txt file.

I am getting "OutputGetting.txt" but I want "OutputRequired.txt"

Thanks a lot in advance for your input.

[twinnyfo]

hrprabhu,

I was unable to test this, as I can't download your tables. However, try this:

Sub DataToBeSent()
On Error GoTo ErrorHandler
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim s As String
    Dim sSQL As String
    Dim dDate As String
    Dim I As Integer
    Dim activeDir As String
    Dim FileNum As Integer
    Dim sCurrentState As String
    Dim sCurrentTeam As String
 
    sCurrentState = ""
    sCurrentTeam = ""
 
    activeDir = CurrentProject.Path
 
    sSQL = "SELECT AFL.StateName, " _
        & "AFL.TeamName, " _
        & "AFL.PlayerSurname, " _
        & "AFL.EndOfSeason " _
        & "FROM AFL " _
        & "ORDER BY AFL.StateName, AFL.TeamName;"
 
 
    Set db = CurrentDb
    Set rs = db.OpenRecordset(sSQL, dbOpenDynaset)
 
    If Not rs.recodcount = 0 Then
        With rs
            .MoveFirst
            s = "State Name" & vbTab & "Club Name" & _
                String(2, vbTab) & "End Of Season" & _
                String(2, vbTab) & "Player Name" & vbCrLf
            Do Until .EOF
                s = s & _
                    IIf(sCurrentState <> !StateName, _
                        !StateName & vbCrLf, _
                        String(2, vbTab)) & _
                    IIf(sCurrentTeam <> !TeamName, _
                        Left(!TeamName & Space(10), 10) & String(2, vbTab) & Left(!EndOfSeason & Space(10), 10) & vbCrLf, _
                        String(6, vbTab)) & _
                    !PlayerSurname & vbCrLf
                If sCurrentState <> !StateName Then
                    sCurrentState = !StateName
                End If
                If sCurrentTeam <> !TeamName Then
                    sCurrentTeam = !TeamName
                End If
                .MoveNext
            Loop
        End With
        SendToFile activeDir & "\OutputGetting.txt", s
    End If
    rs.Close
    db.Close
    Set rs = Nothing
    Set db = Nothing
 
GoTo ThatsIt
ErrorHandler:
    Select Case Err.Number
        Case 3021
        Case Else
            MsgBox "Problem with DataToBeSent()" & vbCrLf _
                 & "Error " & Err.Number & ": " & Err.Description
    End Select
ThatsIt:
    If Not rs Is Nothing Then Set rs = Nothing
    If Not db Is Nothing Then Set db = Nothing
End Sub

Notice Lines 11-15 then 37-50.

Hopefully this will get you closer to where you need to be.

[hrprabhu]

Hi Twinnyfo,
Thank you very much. It worked like a charm!

[twinnyfo]

I'm glad I could be of assistance. Have a great day!

[hrprabhu]

Hi Twinnyfo,

One more change. If I want to put an alphabet before each player's surname. Begin again when the state changes. How do I modify it???

NSW GWS 16 A.Shaw
NSW GWS 16 B.Cameron
NSW GWS 16 C.Patton
NSW GWS 16 D.Mumford
NSW GWS 16 E.Ward
NSW Swans 1 F.Parker
NSW Swans 1 G.Franklin
NSW Swans 1 H.Tippett
NSW Swans 1 I.McGlynn
NSW Swans 1 J.Goodes


Thanks a lot.
Raghu

[twinnyfo]

Now you're being sneaky!

Try This:

Sub DataToBeSent()
On Error GoTo ErrorHandler
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim s As String
    Dim sSQL As String
    Dim dDate As String
    Dim I As Integer
    Dim activeDir As String
    Dim FileNum As Integer
    Dim sCurrentState As String
    Dim sCurrentTeam As String
    Dim iAlpha As Integer
 
    sCurrentState = ""
    sCurrentTeam = ""
    iAlpha = 65
 
    activeDir = CurrentProject.Path
 
    sSQL = "SELECT AFL.StateName, " _
        & "AFL.TeamName, " _
        & "AFL.PlayerSurname, " _
        & "AFL.EndOfSeason " _
        & "FROM AFL " _
        & "ORDER BY AFL.StateName, AFL.TeamName;"
 
    Set db = CurrentDb
    Set rs = db.OpenRecordset(sSQL, dbOpenDynaset)
 
    If Not rs.recodcount = 0 Then
        With rs
            .MoveFirst
            s = "State Name" & vbTab & "Club Name" & _
                String(2, vbTab) & "End Of Season" & _
                String(2, vbTab) & "Player Name" & vbCrLf
            Do Until .EOF
                s = s & _
                    IIf(sCurrentState <> !StateName, _
                        !StateName & vbCrLf, _
                        String(2, vbTab)) & _
                    IIf(sCurrentTeam <> !TeamName, _
                        Left(!TeamName & Space(10), 10) & String(2, vbTab) & Left(!EndOfSeason & Space(10), 10) & vbCrLf, _
                        String(6, vbTab)) & _
                    Chr(iAlpha) & ". " & !PlayerSurname & vbCrLf
                iAlpha = iAlpha + 1
                If sCurrentState <> !StateName Then
                    sCurrentState = !StateName
                End If
                If sCurrentTeam <> !TeamName Then
                    sCurrentTeam = !TeamName
                    iAlpha = 65
                End If
                .MoveNext
            Loop
        End With
        SendToFile activeDir & "\OutputGetting.txt", s
    End If
    rs.Close
    db.Close
    Set rs = Nothing
    Set db = Nothing
 
GoTo ThatsIt
ErrorHandler:
    Select Case Err.Number
        Case 3021
        Case Else
            MsgBox "Problem with DataToBeSent()" & vbCrLf _
                 & "Error " & Err.Number & ": " & Err.Description
    End Select
ThatsIt:
    If Not rs Is Nothing Then Set rs = Nothing
    If Not db Is Nothing Then Set db = Nothing
End Sub

NB: Lines 13, 17, 45, 46, 52

[hrprabhu]

Twinnyfo,
Thanks once again.

[zmbd]

hrprabhu
Hi Twinnyfo,

One more change. If I want to put an alphabet before each player's surname. Begin again when the state changes. How do I modify it??<...>

Hi hrprabhu, TwinnyFo was very generous with time and talent here by providing a complete re-working of you code; however, please keep in mind that we do ask that you make a good faith attempt at obtaining your goal.