Categorised Menu List

Import data from ADODB.database to Excel Spreadsheet

How it works: 

based on the code, the spread sheet is formatted into different styles.

 

to experiment:

  1. Put some data in excel file
  2. copy and paste the following code
  3. assign this to a button on screen
  4. click the button to execute the code.

Context: 

Every spread sheet, before we send to stakeholder should undergo some beautification process.  As a part of this, we see that they are of same font, alignment, row width and so on...

 

    IMPORT DATA FROM ADODB

    TO EXCEL SPREADSHEET

    Dim cnn As ADODB.Connection

    Dim rstGetData As ADODB.Recordset, r As Long
    Dim strSel As String, strMrNo As String

     

    Private Sub cmdExtract_Click()
    On Error GoTo errHandler
    Dim oAccess As Access.Application
    Dim strSql As String
    Dim dtFrom As Date, dtTo As Date, dtOnDate As Date
    Dim lngRecCnt As Long, iCol As Integer, fldCount As Integer, i As Long
    Dim strNoDate As String

        Dim xlApp As Object
        Dim xlBook As Object
        Dim xlSheet As Object

     

        If Me.optExtractAll.Value Then
            strSel = "All"
        ElseIf Me.optOnDate.Value Then
            strSel = "On"
        ElseIf Me.optFromDate.Value Then
            strSel = "From"
        ElseIf Me.optMRNo.Value Then
            strSel = "mRNo"
        Else
            strSel = ""
        End If

     

    Select Case strSel
        Case "All"
            sqlstr = "Select * from tblWorkData"
        
        Case "On"
            If Not IsDate(Me.txtOnDate.Value) Then
                MsgBox "Required DATE value seems to be empty, " & vbCrLf & _
                "Key in in required DATE in mm/dd/yyyy format and Click EXTRACT", vbInformation + vbOKOnly, "Invalid Date..."
                GoTo errHandler
            Else
                dtOnDate = Format(Me.txtOnDate.Value, "mm/dd/yyyy")
            End If
            sqlstr = "Select * from tblWorkData where wDate = #" & dtOnDate & "#"
        
        Case "From"
            If Not IsDate(Me.txtFromDate.Value) Then
                strNoDate = "Yes"
            Else
                dtFrom = Format(Me.txtFromDate.Value, "mm/dd/yyyy")
            End If
            
            If Not IsDate(Me.txtToDate.Value) Then
                strNoDate = "Yes"
            Else
                dtTo = Format(Me.txtToDate.Value, "mm/dd/yyyy", strNoDate = "Yes")
            End If
            
            If strNoDate = "Yes" Then
                MsgBox "One of the dates for the given selection is invalid" & vbCrLf & _
                "Enter appropriate date and CLICK RETRIEVE to retrieve data", vbQuestion + vbOKOnly, "Invalid Date..."
                GoTo errHandler
            Else
                sqlstr = "Select * from tblWorkData where wDate between #" & dtFrom & "# and #" & dtTo & "#"
            End If

        Case "mRNo"
            If IsNull(Me.txtmRNo.Value) Or IsEmpty(Me.txtmRNo.Value) Or Me.txtmRNo.Value = "" Then
                MsgBox "Mail Reference Number (Case Id No:) field seems to be empty" & vbCrLf & _
                "Key in the 12 digit Mail Reference Number (Case Id No:) and Press EXTRACT", vbInformation + vbOKOnly, "Mail Reference Number..."
                GoTo errHandler
            End If
            strMrNo = "Case Id No: " & Me.txtmRNo.Value
            sqlstr = "Select * from tblWorkData where MailRefNo = '" & strMrNo & "'"
        
        Case Else
            MsgBox "Make appropriate selection to retrieve data...", vbQuestion + vbOKOnly, "No Selection..."
            Exit Sub
    End Select

     

    openRecSet
        If rstGetData.State = adStateClosed Then rstGetData.Open sqlstr, cnn
                
        lngRecCnt = rstGetData.RecordCount
            
            If lngRecCnt > 0 Then
                Me.lblStatus.ForeColor = vbRed
                    Me.lblStatus.Caption = "Retrieving Data..."
                MsgBox "Total Number of record(s) retrieved: " & Str(lngRecCnt)

     

    '~~~~~~~~~~~~~~~~~~~ COPY DATA FROM RECORDSET TO EXCEL WORK SHEET~~~~~~~~~~~~~~~~~~~~~
                prcRecSetToExcel
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

     

            Else
                MsgBox "Given selection couldnot retreive any records from database", vbInformation + vbOKOnly, "No Data..."
                GoTo errHandler
            End If

    '        For i = 1 To lngRecCnt
    '            Debug.Print rstGetData.Fields(1) & " - " & rstGetData.Fields(2) & " - " & rstGetData.Fields(4)
    '            rstGetData.MoveNext
    '        Next
            
            If lngRecCnt <= 0 Then
                MsgBox "Data base doesnot contain any data pertaining to the given interval" & vbCrLf & _
                "Select another data interval...", vbInformation + vbOKOnly, "No Data Found..."
            End If

     

    errHandler:
        Select Case Err.Number
            Case 0
                Me.lblStatus.ForeColor = vbGreen
                    Me.lblStatus.Caption = "Completed..."
            
                rstGetData.Close
                cnn.Close
                    Set rstGetData = Nothing
                    Set cnn = Nothing
                    strSel = ""
                    Set xlApp = Nothing
                    Set xlBook = Nothing
                    Set xlSheet = Nothing
            Case 3021
            Case Else
                MsgBox Str(Err.Number) & " " & Err.Description, vbInformation + vbOKOnly, "Extract..."
                Exit Sub
        End Select
    End Sub

     

    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub prcRecSetToExcel()
        Set xlApp = CreateObject("Excel.Application")
        Set xlBook = xlApp.Workbooks.Add
        Set xlSheet = xlBook.Worksheets("Sheet1")
            
        xlApp.UserControl = True
              
        fldCount = rstGetData.Fields.Count
        For iCol = 1 To fldCount
            xlSheet.Cells(1, iCol).Value = rstGetData.Fields(iCol - 1).Name
        Next
                
        xlSheet.Cells(2, 1).CopyFromRecordset rstGetData
        xlApp.Visible = True
    End Sub

    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub openRecSet()
        strDBPath = "D:\Users\703105305\NbcuGmb.mdb"    ' connect to the Access database
        Set cnn = New ADODB.Connection
        'cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source = " & strDBPath & ";"         ' open
        stConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBPath & ";"

        With cnn
            .Open (stConn)                  'Open the connection.
            .CursorLocation = adUseClient   'Necessary to disconnect the recordset.
        End With
        
        Set rstGetData = New ADODB.Recordset
    End Sub

    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub optExtractAll_Click()
        If Me.optExtractAll.Value Then
            strSel = "All"
            prcClearControls
            Me.txtFromDate.Enabled = False
            Me.txtToDate.Enabled = False
            Me.txtOnDate.Enabled = False
        End If
    End Sub

    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub optFromDate_Click()
        If Me.optFromDate.Value Then
            strSel = "From"
            prcClearControls
            Me.txtOnDate.Enabled = False
            Me.txtFromDate.Enabled = True
            Me.txtFromDate.SetFocus
            Me.txtToDate.Enabled = True
        End If
    End Sub

    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub optMRNo_Click()
        If Me.optMRNo.Value Then
            strSel = "mRNo"
            prcClearControls
            Me.txtmRNo.Enabled = True
            Me.txtmRNo.SetFocus
            Me.txtFromDate.Enabled = False
            Me.txtToDate.Enabled = False
            Me.txtOnDate.Enabled = False
        End If
    End Sub

    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub optOnDate_Click()
        If Me.optOnDate.Value Then
            strSel = "On"
            prcClearControls
            Me.txtmRNo.Enabled = False
            Me.txtOnDate.Enabled = True
            Me.txtOnDate.SetFocus
            Me.txtFromDate.Enabled = False
            Me.txtToDate.Enabled = False
        End If
    End Sub

    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub UserForm_Click()
        prcClearControls
        Me.txtmRNo.Enabled = False
        Me.txtFromDate.Enabled = False
        Me.txtOnDate.Enabled = False
        Me.txtToDate.Enabled = False
    End Sub

    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Private Sub prcClearControls()
        Me.txtmRNo.Text = ""
        Me.txtFromDate.Text = ""
        Me.txtToDate.Text = ""
        Me.txtOnDate.Text = ""
    End Sub
     

    Issues you may encounter: While you copy and paste the code from here to code window, replace double quotes in code window again, as these quotes will appear as smart quotes.

     

    The following code is sufficient, a new text file is may not be necessary here...

     

    Code file in .txt format

    It is always advisable to make best use of status bar.  Application.StatusBar = "some text"

    This will help end user to know that the work is in progress...