Add and Paste Recordset object VBA

Question

I'm using an online code that extract data from excel workbooks. However, it only copy and pastes data while I want it to add the data. Lets say the cell I want to copy contains the number "4" and I want to paste it into a cell that already contains the number 5. Instead of showing "4", I want it to show "9". I assume that the line below is what I need to change but couldn't figure out what to change it to

I am working with a range of cell.

Line:

TargetRange.Cells(1, 1).CopyFromRecordset rsData

Full Code:

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

If you're working with a range of cells all in one hit then you can't do this. Nearest thing would be to read the range into a 2D array and iterate over that and the recordset and make amendments in memory — SierraOscar
– SierraOscar, Commented Dec 9, 2016 at 13:40
You can query both the Source and Destination with SQL joins and then add columns. Please show data structure. — Parfait
– Parfait, Commented Dec 9, 2016 at 14:22
This is the code I use to pull the data. Is this what you're referring to by data structure? Call GetData(Filename, "Sheet1", "AV253:DC258", ws.Range(ws.Cells(1 + RowLocation, 1 + 1).Address(0, 0)), False, False) — user2864154
– user2864154, Commented Dec 9, 2016 at 15:07
No, I did not mean how you call your function. I mean what does the data look like? We are blind as we see nothing but your code. Why are you adding those specific values? They must be connected some way, -ID field, another column? Please post example data (few rows) of source and destination ranges. — Parfait
– Parfait, Commented Dec 9, 2016 at 15:25
The source is a group of excel file each with time-series data all located at "AV253:DC258". Each row is one time series. The goal of the destination file is to sum up a particular group of excel file source and plot a "Total time series". The data "AV253:DC258" are just rectangular blocks of numbers and so is the destination. — user2864154
– user2864154, Commented Dec 9, 2016 at 15:43

user6432984 · Accepted Answer · 2016-12-09 16:01:33Z

This is not as eloquent or as fast as using SQL with an ADO Recordset but it is much easier to implement.

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

Slai · Accepted Answer · 2016-12-09 16:15:07Z

0

You might be able to query all sheets at once with something like:

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;]

answered Dec 9, 2016 at 16:15

Slai

23k5 gold badges49 silver badges55 bronze badges

Collectives™ on Stack Overflow

Add and Paste Recordset object VBA

2 Answers 2

Comments

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Related