Access VBA

css navigation by Css3Menu.com

Send Table contents to Excel

My customer keeps coming back wanting different stuff on reports until I had to write a SQL query and embed in VBA to handle the goofiest stuff.
Private Sub cmdNotPaidExcel_Click()
    Dim CurPath     As String
    Dim ExpDate     As Date
    Dim AsOf        As String
    Dim SQLst       As String
    Dim daMont      As String
    Dim daDay       As String
    Dim Quo         As String
On Error GoTo cmdNotPaidExcel_Click_Err
    Quo = Chr(34)	'Single quote character
    DeleteIfExists      'temp table - found on StackOverflow
    ExpDate = InputBox("Type the Expiration Date you desire in the format MM/DD/YYYY", "Get Date", "08/31/" & Year(Now()))
    Select Case Len(Day(ExpDate))
        Case 2
            daDay = Day(ExpDate)
        Case 1
            daDay = "0" & Day(ExpDate)
    End Select
    Select Case Len(Month(ExpDate))
        Case 2
            daMont = Month(ExpDate)
        Case 1
            daMont = "0" & Month(ExpDate)
    End Select
    
    SQLst = "SELECT DISTINCT tblMembers.MemberID, tblMembers.LastName, 
   SQLst = SQLst & "tblMembers.FirstName, tblMembers.OrganizName,"
    SQLst = SQLst & "tblMembers.Street1, tblMembers.City, tblMembers.StateRegion, 
   SQLst = SQLst & "tblMembers.PostalCode, tblMembers.CountryCode, "
    SQLst = SQLst & "IIf(Len([OrganizName])>0,[OrganizName],[FirstName] & Chr(32) & [LastName]) AS daName,"
    SQLst = SQLst & "tblAddtDemographics.Expiration,tblAddtDemographics.Joined, tblMembers.Journal, "
    SQLst = SQLst & "IIf([Deceased]=True," & Quo & "  X" & Quo & "," & Quo & Quo & ") AS Died, tblMembers.MembType, 
   SQLst = SQLst & "tblMembers.Email, "
    SQLst = SQLst & "IIf(IsNull([Telephone])," & Quo & Quo & ","
   SQLst = SQLst & " Left([Telephone],3)&" & Quo & "-" & Quo & "& Mid([telephone],4,3) &" & Quo & "-" & Quo & "& Right([Telephone],4)) AS PHONE"
    SQLst = SQLst & vbCrLf  'Makes SQL easier to read
    SQLst = SQLst & " INTO TempTbl_Expireds"    'To temp table
    SQLst = SQLst & vbCrLf
    SQLst = SQLst & " FROM (tblMembers LEFT JOIN tblPayments ON tblMembers.MemberID = tblPayments.MemID) 
   SQLst = SQLst & " LEFT JOIN tblAddtDemographics ON "
    SQLst = SQLst & "tblMembers.MemberID = tblAddtDemographics.MembID"
    SQLst = SQLst & vbCrLf
    SQLst = SQLst & " WHERE (((tblAddtDemographics.Expiration)=#" & ExpDate & "#))"
    SQLst = SQLst & vbCrLf
    SQLst = SQLst & " ORDER BY tblMembers.LastName, tblMembers.FirstName;"
    Debug.Print SQLst
    DoCmd.SetWarnings False        'Just do it
    DoCmd.RunSQL SQLst
    DoCmd.SetWarnings True
    AsOf = Year(ExpDate) & daMont & daDay
    CurPath = KeyVal("ExportPath") & "XYZ_NotPaids for " & AsOf & " Created _" & Format(Now(), "yyyymmdd") & ".xlsb"
   'Export path is held in a parameters talbe that customer cannot screw up
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "TempTbl_Expireds", CurPath, -1
    '
   ' TransferSpreadsheet
    FormatXLfile CurPath, 2      '9/24/2020  Pretties up the headings
    
cmdNotPaidExcel_Click_Exit:
    MsgBox "Look for spreadsheet at" & vbCrLf & KeyVal("ExportPath"), vbOKOnly
    Exit Sub

cmdNotPaidExcel_Click_Err:
    MsgBox Error$
    Resume cmdNotPaidExcel_Click_Exit

End Sub

The hardest part was making the naming convention work. I also show version date and other info on the menu so they know when they open the wrong version.

Customer did not understand that when the files are opened it changes the datestamp. If he has 10 versions scattered around, eventually they all have recent timestamps.


© 2022-2024

Updated:  06/21/2024 07:42
This page added:  13 October 2022