Thread: Use of Excel to pull data from database daily, posting new data below older data

Hi
.
This seems to work on my box.
.
Notes:
. Uses ADO not DAO
. Tested under Excel 2007 but modifies Provider if not Excel 2007
. Should be able to pop the code below into Excel 2003 but may have
missed something
. Some code needs work to make more industrial strength
HTH
regards
John

Public Function ExcelToAccessToExcel() As Boolean

    ' * Save work book as Macro Workbook
    ' * Add General Module Alt-F11 - Insert Module
    ' * Tools -> References -> Microsoft ActiveX Data Objects 2.8
    ' * Tools -> References -> Microsoft ActiveX Data Recordset 2.8 Library
    ' * Tools -> References -> Microsoft ADO Ext 2.8 for DDL and Security
    ' * Paste this code into Module
    ' * Code should work in 2007/2003
    ' * USES ADO and not DAO
    ' * __ONLY__ tested as 2007 Excel

    On Error GoTo EH_ExcelToAccessToExcel

    '------------------------------
    '   Objects
    '------------------------------
    Dim oCN As ADODB.Connection
    Dim oRS As ADODB.Recordset
    
    '------------------------------
    '   Properties
    '------------------------------
    Dim sProvider As String
    Dim sPath As String
    Dim sACCDBName As String
    Dim sWBName As String
    Dim sExtender As String
    Dim sDataSource As String
    Dim sCNString As String
    
    '------------------------------
    '   Counters
    '------------------------------
    Dim mlngRSRecCNT As Long
    Dim mlngRSFieldCNT As Long
    
    '------------------------------
    '   Misc
    '------------------------------
    Dim i As Integer
    Dim lng As Long
    
    '------------------------------
    '   SQL variables
    '------------------------------
    Dim sSQL As String

    '------------------------------
    '   Part 1 - Excel To Access
    '------------------------------
    If Application.Version = 12# Then
        sProvider = "Microsoft.ACE.OLEDB.12.0;"
    Else
        'Not Tested
        sProvider = "Microsoft.Jet.OLEDB.4.0"
    End If
    sPath = ThisWorkbook.Path & "\"         'Change to yours
    sACCDBName = "DBTarget.accdb"           'Change to yours E.G. ABC.MDB etc, Change variable to sMDBName
    sExtender = vbNullString
    sDataSource = "Data Source = " & sPath & sACCDBName

    '------------------------------
    '   Connect To Access
    '------------------------------
    Set oCN = Nothing
    Set oCN = New ADODB.Connection
    With oCN
        .Provider = sProvider
        .ConnectionString = sDataSource
        .Open
    End With

    '------------------------------
    '   SQL Statement
    '------------------------------
    sSQL = "SELECT "
    sSQL = sSQL & " * "
    sSQL = sSQL & " FROM "
    sSQL = sSQL & " [TargetTable] " 'Change
    '------------------------------
    '   OPTIONAL
    '------------------------------
    If 1 = 2 Then
        sSQL = sSQL & " ORDER BY "
        sSQL = sSQL & " [lastref] "  'Change
    End If

    '------------------------------
    '   WB - Recordset
    '------------------------------
    Set oRS = Nothing
    Set oRS = New ADODB.Recordset
    With oRS
        .ActiveConnection = oCN
        .CursorLocation = adUseClient
        .CursorType = adOpenDynamic
        .LockType = adLockBatchOptimistic
        .Source = sSQL
        .Open
    End With
    If Not oRS.BOF And Not oRS.EOF Then
        oRS.MoveLast
        oRS.MoveFirst
        mlngRSRecCNT = oRS.RecordCount
        mlngRSFieldCNT = oRS.Fields.Count
    Else
        'Add MSG
        ExcelToAccessToExcel = False
        Exit Function
    End If

    '------------------------------
    '   Part 2 - Excel To Excel
    '------------------------------
    Dim oWSTarget As Excel.Worksheet
    Dim oRngCurReg As Excel.Range
    Dim oRngDummy As Excel.Range
    Dim sWSTargetName As String
    Dim lngRowCnt As Long
    Dim lngColCnt As Long
    Dim bFirstTime As Boolean

    '------------------------------
    '   Init
    '------------------------------
    bFirstTime = False
    sWSTargetName = "Target"    'Change to yours
    Set oWSTarget = Sheets(sWSTargetName)
    
    '------------------------------
    '   Range Object
    '------------------------------
    With oWSTarget
        Set oRngCurReg = .Range("a1").CurrentRegion
        lngRowCnt = oRngCurReg.Rows.Count
        lngColCnt = oRngCurReg.Columns.Count
    End With

    '------------------------------
    '   Column vs Fields Check
    '------------------------------
    '   Improve this
    '   Write your own message
    '------------------------------
    If lngRowCnt > 1 Then
        If mlngRSFieldCNT <> lngColCnt Then
            MsgBox "Field Cnt not equal Range Column Count - BAD", vbCritical, "Public Function ExcelToAccessToExcel()"
            ExcelToAccessToExcel = False
            Exit Function
        End If
    End If

    '------------------------------
    '   Anything in Range
    '   Improve this
    '------------------------------
    If (lngRowCnt = 1 And lngColCnt = 1) Then
        bFirstTime = True
    End If

    '------------------------------
    '   Improve this
    '------------------------------
    Select Case bFirstTime
    Case True
        '-------------------------
        '   Write Headings to WS Target
        '   Write Data To WS Target
        '-------------------------
        For lng = 0 To mlngRSFieldCNT - 1
            oWSTarget.Rows(1).Columns(lng + 1) = oRS.Fields(lng).Name
        Next
        With Sheets("Target").Range("A1").Offset(1)
            .CopyFromRecordset oRS
        End With
    Case False
        With oWSTarget
            Set oRngDummy = .Range(oRngCurReg.Address).Offset(oRngCurReg.Rows.Count, 0)
        End With
        oRngDummy.CopyFromRecordset oRS
    End Select

    '------------------------
    '   Kill Objects
    '------------------------
    On Error Resume Next
    If oRS.State > 0 Then
        oRS.Close
        Set oRS = Nothing
    Else
        Set oRS = Nothing
    End If
    If oCN.State > 0 Then
        oCN.Close
        Set oCN = Nothing
    Else
        Set oCN = Nothing
    End If

    '------------------------
    '   Exit
    '------------------------
    ExcelToAccessToExcel = True
    Exit Function
EH_ExcelToAccessToExcel:
    MsgBox Err.Number & " " & Err.Description, vbCritical, "Public Function ExcelToAccessToExcel()"
    ExcelToAccessToExcel = False
    Exit Function


End Function

Note:
Change This line
sProvider = "Microsoft.Jet.OLEDB.4.0"
To this line
sProvider = "Microsoft.Jet.OLEDB.4.0;"
.
Should work either way but have not tested in Excel 2003