Updating fetched access data to excel at appropriate places

Question

I am to develop specific vba application in excel in which i have two buttons. First Button: browse *.xlsm file and place it in current worksheet. Second Button: compares one column name with the column of access database. Then if the row matches for a specific column, it then places the values of the matched row from access to specified fields in database.

Here i am compairing particular database column with excel column.

But i am not able to find a way that how should i place the data which is being fetched from the database after compairing and placing that matched data into the appropriate places in the compared row every time

what my code is doing right now that it is placing the fetched data in the from specified (CA3) and just once, not the no. of times it compares. 'Constant for Database connection string

 Private Const glob_DBPath = "C:\Users\Xprts8\Documents\shipping.accdb"

  Option Explicit

  Private Const glob_sConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" " &_ 
           "& glob_DBPath & "';"   
   Private Sub RetrieveRecordset(strSQL As String, clTrgt As Range)

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
Dim x, y As String
Dim j As Integer
Dim mysheet

Set mysheet = ThisWorkbook.Sheets("Sheet1")
'Open connection to the database
cnt.Open glob_sConnect

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

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



 Do Until rst.EOF = True
 x = rst.Fields("Comp_name")
 For j = 2 To lFields
 y = mysheet.Cells(j, "AE")

If x = y Then

'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
End If
Next

rst.MoveNext
Loop

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 

This function is being called by the following code on button click,

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 * FROM [Indian_Data];"
Set rngTarget = ActiveSheet.Range("CA3")
Call RetrieveRecordset(sSQLQry, rngTarget)
End Sub

Is this following line is giving problem? because it is setting the range, So, should i put this in loop where i compared the columns so that it loops and prints the data as many no of times as it compares

   Set rngTarget = ActiveSheet.Range("CA3")

Can anybody help me out in this problem?

Answer 1

UPDATED

What you should probably do instead of editing the RetrieveRecordset function is to place your criteria directly into the SQL string in the button click code:

Public Sub GetRecords()
    Dim rr As clsRetrieveRecordset
    Set rr = New clsRetrieveRecordset
    rr.Connect ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source='C:\Users\Xprts8\Documents\shipping.accdb'")
    Dim rngTarget As Range
    Dim rngCompare As Range
    Set rngCompare = Range(Range("AE3"), Range("AE3").End(xlDown))
    Set rngTarget = Range("CA3")
    For i = 0 To rngCompare.Rows.Count - 1
        rr.RetrieveRecordset "SELECT TOP 1 * FROM [Indian_Data] WHERE [Comp_name]='" & rngCompare.Offset(i, 0) & "'", rngTarget.Offset(i, 0)
    Next
End Sub

I'm not sure what the lFields variable is, but it should be declared the same as it would have been in the RetrieveRecordset function.

---

Here is a quick and dirty fix of the RetrieveRecords function. Place the following code into a Class Module called clsRetrieveRecord.

Option Explicit

'Private Const glob_sConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & _
'           "& glob_DBPath & " ';"
'Private Const glob_DBPath = "C:\Users\Xprts8\Documents\shipping.accdb"

Private m_Connection As ADODB.Connection

Public Sub Connect(strConnect As String) ', Optional UserID As String, Optional Password As String)
    'Connect to the database
    Set m_Connection = New ADODB.Connection
    m_Connection.Open strConnect
End Sub

Public Sub RetrieveRecordset(strSQL As String, rngTarget As Range, Optional lngRecords As Long)
    Dim cnt As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim rcArray As Variant
    Dim lRecrds As Long
    Dim lFields As Long
    Dim lCol As Long
    Dim lRow As Long
    Dim x, y As String
    Dim i As Integer
    Dim mysheet
    Dim clTrgt As Range

    If m_Connection Is Nothing Then
        'Error!
    End If

    'Open recordset based on table
    rst.Open strSQL, m_Connection

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

    Do Until rst.EOF = True
        For i = 1 To lFields
            '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
                rngTarget.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
                    rngTarget.Resize(lRecrds, lFields).Value = TransposeDim(rcArray)
                End If
            End If
        Next

        rst.MoveNext
    Loop

EarlyExit:
    'Close and release the ADO objects
    rst.Close
    Set rst = 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

Private Sub Class_Terminate()
    m_Connection.Close
    Set m_Connection = Nothing
End Sub

I have kind of been toying with the idea of making a generic way of pulling records from database queries into Excel, so I will probably refine the code into something reusable. When I do, I'll post back here. Let me know if it doesn't work. You will have to modify the cell references to match your data