0

我要在 excel 中开发特定的 vba 应用程序，其中我有两个按钮。第一个按钮：浏览 *.xlsm 文件并将其放在当前工作表中。第二个按钮：将一个列名与access数据库的列进行比较。然后，如果该行与特定列匹配，则它将匹配行的值从访问到数据库中的指定字段。

在这里，我将特定的数据库列与 excel 列进行比较。

但是我无法找到一种方法，我应该如何在每次比较并将匹配的数据放置到比较行中的适当位置之后放置从数据库中获取的数据

我的代码现在正在做什么，它将获取的数据放在指定的（CA3）中，并且只放置一次，而不是没有。它比较的次数。'数据库连接字符串常量

 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

此函数在按钮单击时由以下代码调用，

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

下面这行有问题吗？因为它正在设置范围，所以，我应该把它放在我比较列的循环中，以便它循环和打印数据的次数与它比较的次数一样多

   Set rngTarget = ActiveSheet.Range("CA3")

有人可以帮我解决这个问题吗？

4

1 回答 1

1

更新

您可能应该做的而不是编辑RetrieveRecordset函数是将您的条件直接放入按钮单击代码中的 SQL 字符串中：

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

我不确定 lFields 变量是什么，但它应该与RetrieveRecordset函数中的声明相同。

这是 RetrieveRecords 函数的快速而肮脏的修复。将以下代码放入名为 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

我一直在玩弄一种将数据库查询中的记录提取到 Excel 中的通用方法的想法，因此我可能会将代码改进为可重用的东西。当我这样做时，我会回到这里。让我知道它是否不起作用。 您将不得不修改单元格引用以匹配您的数据

于 2013-11-13T19:31:47.280 回答