transfer Data in filtered query to excel

T

theinviter

Registered User.
Local time
Today, 00:08
Joined
Aug 14, 2014
Messages
273
Dear Guys;
Need help,

I have a data in my filtered form tat extracted form query, and need help on how to convert it to excel sheet in desktop by click on a button with VBa code.

thanks
 
Code: 
Public Function fncExportFormRecords _
                            (ByVal strExportTo As String, _
                            ByVal Frm As Form, _
                            ByVal strFilename As String _
                            ) As Boolean
' arnelgp
'_______________________________________
' strExportTo   either "Excel" or "Text"
' Frm           the form you need to Export to Excel or Text file
' strFileName   the Excel/Text filename to create
'
    On Error GoTo fncExportFormRecordsToExcel_Error
    'arnelgp
    Const TEST_QUERY As String = "zzQuery"
    Dim strSql As String
    Dim strSelect As String
    Dim strWhere As String
    Dim strWhereAdd As String
    Dim strOrderBy As String
    Dim strGROUPBY As String
    Dim strHAVING As String

    Dim db As DAO.Database
    Dim qd As DAO.QueryDef

    ' get the SQL from the form
    strSql = Frm.RecordSource
    If Left(strSql, 7) <> "SELECT " Then
        strSql = "SELECT * FROM " & strSql
    End If
    strSql = Replace(strSql, ";", "")
    ' get the filter of form
    If Frm.FilterOn = True Then
        strWhereAdd = Trim(RemoveFormReference(Frm.Filter))
    End If
    ' parse the SQL
    Call ParseSQL(strSql, _
        strSelect, _
        strWhere, _
        strOrderBy, _
        strGROUPBY, _
        strHAVING)
    If Len(strWhere) > 0 Then
        strWhere = " " & Trim(strWhere)
    End If
    If Len(strWhereAdd) > 0 Then
        If Len(strWhere) > 0 Then
            strWhere = strWhere & " AND " & strWhereAdd
        Else
            strWhere = " WHERE " & strWhereAdd
        End If
    End If
    'assemble again the SQL
    strSql = strSelect & strWhere & strOrderBy & strGROUPBY & strHAVING

    Set db = CurrentDb
    'use the temporary query if it exists
    On Error Resume Next
    Set qd = db.QueryDefs(TEST_QUERY)
    If Err.Number <> 0 Then
        Set qd = db.CreateQueryDef(TEST_QUERY, strSql)
    End If
    qd.SQL = strSql
    Set qd = Nothing
    db.QueryDefs.Refresh
    Set db = Nothing
    Application.RefreshDatabaseWindow
    On Error GoTo fncExportFormRecordsToExcel_Error
    
    Select Case strExportTo
        Case "Excel"
            'export to excel
            DoCmd.TransferSpreadsheet _
                            TransferType:=acExport, _
                            TableName:=TEST_QUERY, _
                            filename:=strFilename, _
                            HasFieldNames:=True
            Do Until Len(Dir(strFilename)) > 0
                DoEvents
            Loop
            Do Until VBA.FileLen(strFilename) > 0
                DoEvents
            Loop
            ' rename the sheet on the workbook
            Dim oExcel As Object            'Excel.Application
            Dim oWB As Object               'Excel.Workbook
            Dim oSH As Object               'Excel.Worksheet
            Dim i As Integer
            Set oExcel = CreateObject("Excel.Application")
            Set oWB = oExcel.Workbooks.Open(strFilename)
            For Each oSH In oWB.Worksheets
                If oSH.NAME Like "Export*" Then
                    i = i + 1
                End If
            Next
            For Each oSH In oWB.Worksheets
                If oSH.NAME = TEST_QUERY Then
                    oSH.NAME = "Export" & IIf(i > 0, "(" & i & ")", "")
                    Exit For
                End If
            Next
            oWB.Save
            Set oSH = Nothing
            Set oWB = Nothing
            oExcel.Quit
            Set oExcel = Nothing
        Case "Text"
            DoCmd.TransferText _
                            TransferType:=acExportDelim, _
                            TableName:=TEST_QUERY, _
                            filename:=strFilename, _
                            HasFieldNames:=True
    End Select
    On Error GoTo 0
    If Frm.FilterOn Then
        MsgBox "Filtered records exported to " & strFilename & ".", vbInformation
    Else
        MsgBox "Records exported to " & strFilename & ".", vbInformation
    End If
    fncExportFormRecords = True
    
    Exit Function

fncExportFormRecordsToExcel_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure fncExportFormRecordsToExcel, line " & Erl & "."

End Function

on the click event of your Button on the form:

private sub button1_click()
call fncExportFormRecords("Excel", Me, Environ$("UserProfile") & "\Desktop\Export.xlsx")
end sub
 
the other file:
 

Attachments

arnelgp said:
Code: 
Public Function fncExportFormRecords _
                            (ByVal strExportTo As String, _
                            ByVal Frm As Form, _
                            ByVal strFilename As String _
                            ) As Boolean
' arnelgp
'_______________________________________
' strExportTo   either "Excel" or "Text"
' Frm           the form you need to Export to Excel or Text file
' strFileName   the Excel/Text filename to create
'
    On Error GoTo fncExportFormRecordsToExcel_Error
    'arnelgp
    Const TEST_QUERY As String = "zzQuery"
    Dim strSql As String
    Dim strSelect As String
    Dim strWhere As String
    Dim strWhereAdd As String
    Dim strOrderBy As String
    Dim strGROUPBY As String
    Dim strHAVING As String

    Dim db As DAO.Database
    Dim qd As DAO.QueryDef

    ' get the SQL from the form
    strSql = Frm.RecordSource
    If Left(strSql, 7) <> "SELECT " Then
        strSql = "SELECT * FROM " & strSql
    End If
    strSql = Replace(strSql, ";", "")
    ' get the filter of form
    If Frm.FilterOn = True Then
        strWhereAdd = Trim(RemoveFormReference(Frm.Filter))
    End If
    ' parse the SQL
    Call ParseSQL(strSql, _
        strSelect, _
        strWhere, _
        strOrderBy, _
        strGROUPBY, _
        strHAVING)
    If Len(strWhere) > 0 Then
        strWhere = " " & Trim(strWhere)
    End If
    If Len(strWhereAdd) > 0 Then
        If Len(strWhere) > 0 Then
            strWhere = strWhere & " AND " & strWhereAdd
        Else
            strWhere = " WHERE " & strWhereAdd
        End If
    End If
    'assemble again the SQL
    strSql = strSelect & strWhere & strOrderBy & strGROUPBY & strHAVING

    Set db = CurrentDb
    'use the temporary query if it exists
    On Error Resume Next
    Set qd = db.QueryDefs(TEST_QUERY)
    If Err.Number <> 0 Then
        Set qd = db.CreateQueryDef(TEST_QUERY, strSql)
    End If
    qd.SQL = strSql
    Set qd = Nothing
    db.QueryDefs.Refresh
    Set db = Nothing
    Application.RefreshDatabaseWindow
    On Error GoTo fncExportFormRecordsToExcel_Error
   
    Select Case strExportTo
        Case "Excel"
            'export to excel
            DoCmd.TransferSpreadsheet _
                            TransferType:=acExport, _
                            TableName:=TEST_QUERY, _
                            filename:=strFilename, _
                            HasFieldNames:=True
            Do Until Len(Dir(strFilename)) > 0
                DoEvents
            Loop
            Do Until VBA.FileLen(strFilename) > 0
                DoEvents
            Loop
            ' rename the sheet on the workbook
            Dim oExcel As Object            'Excel.Application
            Dim oWB As Object               'Excel.Workbook
            Dim oSH As Object               'Excel.Worksheet
            Dim i As Integer
            Set oExcel = CreateObject("Excel.Application")
            Set oWB = oExcel.Workbooks.Open(strFilename)
            For Each oSH In oWB.Worksheets
                If oSH.NAME Like "Export*" Then
                    i = i + 1
                End If
            Next
            For Each oSH In oWB.Worksheets
                If oSH.NAME = TEST_QUERY Then
                    oSH.NAME = "Export" & IIf(i > 0, "(" & i & ")", "")
                    Exit For
                End If
            Next
            oWB.Save
            Set oSH = Nothing
            Set oWB = Nothing
            oExcel.Quit
            Set oExcel = Nothing
        Case "Text"
            DoCmd.TransferText _
                            TransferType:=acExportDelim, _
                            TableName:=TEST_QUERY, _
                            filename:=strFilename, _
                            HasFieldNames:=True
    End Select
    On Error GoTo 0
    If Frm.FilterOn Then
        MsgBox "Filtered records exported to " & strFilename & ".", vbInformation
    Else
        MsgBox "Records exported to " & strFilename & ".", vbInformation
    End If
    fncExportFormRecords = True
   
    Exit Function

fncExportFormRecordsToExcel_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure fncExportFormRecordsToExcel, line " & Erl & "."

End Function

on the click event of your Button on the form:

private sub button1_click()
call fncExportFormRecords("Excel", Me, Environ$("UserProfile") & "\Desktop\Export.xlsx")
end sub
Click to expand...
got compile error in this line :
strWhereAdd = Trim(RemoveFormReference(Frm.Filter))
 
the missing function:
Code: 
Public Function RemoveFormReference(SQLCode As String) As String

'   The purpose of this function is to take an SQL statement and convert
'   a reference to a form control into a literal value

'For example, in SQL code, we need to change this:
'WHERE (((tblAmounts.intType) = [Forms]![frmTypeSelector]![cmbType]))
'OR this:
'WHERE (((tblAmounts.intType) = Forms!frmTypeSelector!cmbType))
'...to this, if the value is a number:
'WHERE (((tblAmounts.intType) = 1))
'...or this, if the value is a string:
'WHERE (((tblAmounts.strName)='Dennis'))
'...or this, if the value is a Date:
'WHERE (((tblAmounts.DateField)=#10/1/2015#))


    Dim intFormRefPos As Integer, strFormName As String, strCtlName As String
    Dim strTemp As String

'   If no form references are found, just return the string argument
'   If a form reference IS found, manipulate the string argument first, then return it

'   Find the first type of form reference (see examples above)
    intFormRefPos = InStr(1, SQLCode, "[Forms]![")
    If intFormRefPos > 0 Then
'       Extract the form name and control name from the SQL code
        strFormName = Mid(SQLCode, intFormRefPos + 9)
        strFormName = Left(strFormName, InStr(1, strFormName, "]") - 1)
        strCtlName = Mid(SQLCode, intFormRefPos + 9 + Len(strFormName) + 3)
        strCtlName = Left(strCtlName, InStr(1, strCtlName, "]") - 1)
        
'       Insert the literal value in the place of the control reference
        strTemp = Left(SQLCode, intFormRefPos - 1)
        If IsNumeric(Forms(strFormName).Controls(strCtlName)) = False Then
            If IsDate(Forms(strFormName).Controls(strCtlName)) Then
                strTemp = strTemp & "#"
            Else
                strTemp = strTemp & "'"
            End If
        End If
        strTemp = strTemp & Forms(strFormName).Controls(strCtlName)
        If IsNumeric(Forms(strFormName).Controls(strCtlName)) = False Then
            If IsDate(Forms(strFormName).Controls(strCtlName)) Then
                strTemp = strTemp & "#"
            Else
                strTemp = strTemp & "'"
            End If
        End If
        strTemp = strTemp & Mid(SQLCode, intFormRefPos + 9 + Len(strFormName) + 3 + Len(strCtlName) + 1)
        SQLCode = strTemp
    Else
'       Find the second type of form reference (see examples above)
        intFormRefPos = InStr(1, SQLCode, "Forms!")
        If intFormRefPos > 0 Then
'           Extract the form name and control name from the SQL code
            strFormName = Mid(SQLCode, intFormRefPos + 6)
            strFormName = Left(strFormName, InStr(1, strFormName, "!") - 1)
            strCtlName = Mid(SQLCode, intFormRefPos + 6 + Len(strFormName) + 1)
            strCtlName = Left(strCtlName, InStr(1, strCtlName, ")") - 1)

'           Insert the literal value in the place of the control reference
            strTemp = Left(SQLCode, intFormRefPos - 1)
            If IsNumeric(Forms(strFormName).Controls(strCtlName)) = False Then
                If IsDate(Forms(strFormName).Controls(strCtlName)) Then
                    strTemp = strTemp & "#"
                Else
                    strTemp = strTemp & "'"
                End If
            End If
            strTemp = strTemp & Forms(strFormName).Controls(strCtlName)
            If IsNumeric(Forms(strFormName).Controls(strCtlName)) = False Then
                If IsDate(Forms(strFormName).Controls(strCtlName)) Then
                    strTemp = strTemp & "#"
                Else
                    strTemp = strTemp & "'"
                End If
            End If
            strTemp = strTemp & Mid(SQLCode, intFormRefPos + 6 + Len(strFormName) + 1 + Len(strCtlName))
            SQLCode = strTemp
        End If
    End If

    RemoveFormReference = SQLCode

End Function
 
You must log in or register to reply here.

Similar threads

S
REPORT TO EXCEL FORMAT
Replies
8
Views
738
Gasman
Gasman
MattBaldry
Solved Form Filter in VBA
Replies
15
Views
940
MattBaldry
MattBaldry
N
Solved Transferring data from unbound MS Access Form to another form
Replies
18
Views
392
nector
N
oxicottin
Solved Import from excel and delete unwanted data
Replies
14
Views
1,544
oxicottin
oxicottin
D
Solved Open a report that filters off a form field
Replies
7
Views
1,004
dullster
D

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom