please help me modify my vba code

roykana

Active Member
Joined
Mar 8, 2018
Messages
311
Office Version
  1. 2010
Platform
  1. Windows
Dear All master,
I want to connect with multi data source for dbf file with vba array code.
what I want is the following:
1. Modify the connection string according to the dbase file provider
2. Can I connect with my multi DSN reference and become one sheet
Data Source NameDefaultDirFILE NAME DBF
HOF-NOWV:\NOWIFG.DBF
TT1-NOWZ:\DATA\MALFIN 18\NOWIFG.DBF
TT2-NOWZ:\DATA\MALFIN D2\NOWIFG.DBF
TT3-NOWZ:\DATA\MALFIN 07\NOWIFG.DBF

3. I want incoming data with headers from source file
VBA Code:
Option Explicit
'Constant for Database connection string
Private Const DB_DBPath = "C:\Temp\IFG.ACCDB"
Private Const DB_sConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & DB_DBPath & "';"     'For use with *.accdb files

Private Sub copyRecordset(strSQL As String, clTrgt As Range)
'Macro Purpose: To copy a recordset from a database (via an SQL query) and place
'               it in the supplied worksheet range
'NOTE         : Requires a reference to "Microsoft ActiveX Data Objects 2.x Library"
'               (Developed with reference to version 2.0 of the above)

    Dim cnt As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim rcArray As Variant
    Dim lFields As Long
    Dim lRecrds As Long
    Dim lCol As Long
    Dim lRow As Long

    'Open connection to the database
    cnt.Open DB_sConnect

    'Open recordset based on Orders table
    rst.Open strSQL, cnt

    'Count the number of fields to place in the worksheet
    lFields = rst.Fields.Count

    'Check version of Excel
    If Val(Mid(Application.Version, 1, InStr(1, Application.Version, ".") - 1)) > 8 Then
        'EXCEL 2000 or 2002: Use CopyFromRecordset
        'Copy the recordset from the database
        On Error Resume Next
        clTrgt.CopyFromRecordset rst
        
        'CopyFromRecordset will fail if the recordset contains an OLE
        'object field or array data such as hierarchical recordsets
        If Err.Number <> 0 Then GoTo EarlyExit
    
    Else
        'EXCEL 97 or earlier: Use GetRows then copy array to Excel
        'Copy recordset to an array
        rcArray = rst.GetRows

        'Determine number of records (adds 1 since 0 based array)
        lRecrds = UBound(rcArray, 2) + 1

        'Check the array for contents that are not valid when
        'copying the array to an Excel worksheet
        For lCol = 0 To lFields - 1
            For lRow = 0 To lRecrds - 1
                'Take care of Date fields
                If IsDate(rcArray(lCol, lRow)) Then
                    rcArray(lCol, lRow) = Format(rcArray(lCol, lRow))
                    'Take care of OLE object fields or array fields
                ElseIf IsArray(rcArray(lCol, lRow)) Then
                    rcArray(lCol, lRow) = "Array Field"
                End If
            Next lRow
        Next lCol

        'Transpose and place the array in the worksheet
        clTrgt.Resize(lRecrds, lFields).Value = TransposeDim(rcArray)
    End If

EarlyExit:
    'Close and release the ADO objects
    rst.Close
    cnt.Close
    Set rst = Nothing
    Set cnt = Nothing
    On Error GoTo 0
End Sub

Private Function TransposeDim(v As Variant) As Variant
'Function Purpose:  Transpose a 0-based array (v)
    Dim x As Long, Y As Long, Xupper As Long, Yupper As Long
    Dim tempArray As Variant

    Xupper = UBound(v, 2)
    Yupper = UBound(v, 1)

    ReDim tempArray(Xupper, Yupper)
    For x = 0 To Xupper
        For Y = 0 To Yupper
            tempArray(x, Y) = v(Y, x)
        Next Y
    Next x

    TransposeDim = tempArray
End Function

Sub GetRecords()
'Macro Purpose: To retrieve a recordset to an Excel worksheet
    Dim sSQLQry As String
    Dim rngTarget As Range

    'Generate the SQL query and set the range to place the data in
    sSQLQry = "SELECT IFG.GDN, IFG.ITM, " & _
            "IFG.ITC, IFG.QOH FROM IFG;"
    ActiveSheet.Cells.ClearContents
    Set rngTarget = ActiveSheet.Range("A2")

    'Retrieve the records
    Call copyRecordset(sSQLQry, rngTarget)
End Sub
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
Dear all master,

Can help me my posting?
thanks
roykana
 
Upvote 0

Forum statistics

Threads
1,223,162
Messages
6,170,432
Members
452,326
Latest member
johnshaji

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top