添加和粘贴 Recordset 对象 VBA

Question

我正在使用从 excel 工作簿中提取数据的在线代码。但是，它只复制和粘贴数据，而我希望它添加数据。假设我要复制的单元格包含数字“4”，我想将它粘贴到一个已经包含数字 5 的单元格中。我不想显示“4”，而是希望它显示“9”。我认为下面的行是我需要更改的内容，但无法弄清楚要将其更改为什么

我正在处理一系列单元格。

行：

TargetRange.Cells(1, 1).CopyFromRecordset rsData

完整代码：

Option Explicit


Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
               SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)

Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long

' Create the connection string.
If Header = False Then
    If Val(Application.Version) < 12 Then
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                    "Data Source=" & SourceFile & ";" & _
                    "Extended Properties=""Excel 8.0;HDR=No"";"
    Else
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                    "Data Source=" & SourceFile & ";" & _
                    "Extended Properties=""Excel 12.0 Macro;HDR=No"";"
    End If
Else
    If Val(Application.Version) < 12 Then
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                    "Data Source=" & SourceFile & ";" & _
                    "Extended Properties=""Excel 8.0;HDR=Yes"";"
    Else
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                    "Data Source=" & SourceFile & ";" & _
                    "Extended Properties=""Excel 12.0;HDR=Yes"";"
    End If
End If

If SourceSheet = "" Then
    ' workbook level name
    szSQL = "SELECT * FROM " & SourceRange$ & ";"
Else
    ' worksheet level name or range
    szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
End If

On Error GoTo SomethingWrong

Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")

rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1

' Check to make sure we received data and copy the data
If Not rsData.EOF Then

    If Header = False Then
        TargetRange.Cells(1, 1).CopyFromRecordset rsData
    Else
        'Add the header cell in each column if the last argument is True
        If UseHeaderRow Then
            For lCount = 0 To rsData.Fields.Count - 1
                TargetRange.Cells(1, 1 + lCount).Value = _
                rsData.Fields(lCount).Name
            Next lCount
            TargetRange.Cells(2, 1).CopyFromRecordset rsData
        Else
            TargetRange.Cells(1, 1).CopyFromRecordset rsData
        End If
    End If

Else
    MsgBox "No records returned from : " & SourceFile, vbCritical
End If

' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub

SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
       vbExclamation, "Error"
On Error GoTo 0

End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).row
On Error GoTo 0
End Function


Function Array_Sort(ArrayList As Variant) As Variant
Dim aCnt As Integer, bCnt As Integer
Dim tempStr As String

For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1
    For bCnt = aCnt + 1 To UBound(ArrayList)
        If ArrayList(aCnt) > ArrayList(bCnt) Then
            tempStr = ArrayList(bCnt)
            ArrayList(bCnt) = ArrayList(aCnt)
            ArrayList(aCnt) = tempStr
        End If
    Next bCnt
Next aCnt
Array_Sort = ArrayList
End Function

Answer 1

这不如 eloquent 或使用 SQL 与 ADO 记录集一样快，但它更容易实现。

Public Sub GetData(SourceFile As Variant, SourceSheet As String, SourceRange As String, TargetRange As Range)
    Application.ScreenUpdating = False
    Dim CloseFile As Boolean
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(SourceFile)
    On Error GoTo 0
    If wb Is Nothing Then
        CloseFile = True
        Set wb = Workbooks.Open(Filename:=SourceFile, ReadOnly:=True)
    End If

    With wb
        With .Worksheets(SourceSheet)
            .Range(SourceRange).Copy
            TargetRange.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:=False, Transpose:=False
        End With
        If CloseFile Then .Close SaveChanges:=False
    End With

    Application.ScreenUpdating = True
End Sub

Answer 2

您可以使用类似以下内容的方式一次查询所有工作表：

SELECT * FROM [Sheet1$AV253:DC258] IN 'C:\Book1.xls'[Excel 12.0;] UNION ALL
SELECT * FROM [Sheet1$AV253:DC258] IN 'C:\Book2.xls'[Excel 12.0;]

添加和粘贴 Recordset 对象 VBA

Add and Paste Recordset object VBA

excel

vba

ado