Access VBA

Send Table contents to Excel

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

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.