我要在excel中开发特定的vba应用程序，其中我有两个按钮。第一个按钮：浏览* .xlsm文件并将其放在当前工作表中。第二个按钮：将一个列名与访问数据库列进行比较。然后，如果该行匹配特定列，则将匹配行的值从访问放置到数据库中的指定字段。
在这里，我使用excel列对特定的数据库列进行比较。
但我无法找到一种方法，在每次进行比较并将匹配的数据放入比较行的适当位置后，如何放置从数据库中提取的数据
我的代码现在正在做什么，它将获取的数据放在from指定的（CA3）中，只放置一次，而不是no。比较的时间。 '数据库连接字符串的常量
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")
有人可以帮我解决这个问题吗？
答案 0 :(得分：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的通用方法，因此我可能会将代码细化为可重用的东西。当我这样做时，我会在这里回复。如果它不起作用，请告诉我。 您必须修改单元格引用以匹配您的数据