VBA help Copy from Record Set

joesef

Board Regular
Joined
Sep 5, 2008
Messages
189
Code:
Sub cmdRefresh()

    If GetConnectionString = False Then
        Exit Sub
    End If



    Dim oWorkbook As Workbook
    Dim oWorksheet As Worksheet
    Dim oRange As Range
    Dim oRS As ADODB.Recordset
    
    Set oWorkbook = ActiveWorkbook
    
    
    ' Get SQL String
    Set oWorksheet = oWorkbook.Worksheets("SQL")
    Set oRange = oWorksheet.Range("A1")
    Dim sSQL As String
    sSQL = Trim(oRange.Value)
    On Error Resume Next
    Set oRS = modMain.GetSQLData(sSQL)
    If Err <> 0 Then
        MsgBox "Problem retrieving data : " & Err.Description, vbExclamation, "Get Data"
        Exit Sub
    End If
    On Error GoTo 0
    
    
    
    Set oWorksheet = oWorkbook.Worksheets("Data")
    Set oRange = oWorksheet.Range("B1")
    Call oRange.CopyFromRecordset(oRS)
    oRS.Close
    
    
    Set oWorksheet = oWorkbook.Worksheets("Summary")
    
    Dim oPT As PivotTable
    For Each oPT In oWorksheet.PivotTables
        oPT.RefreshTable
    Next
    
    
    
    
    
End Sub

I'm having trouble editing my code so that the data is copied from the record set and entered Vertically in B1 instead of Horizontally...Any ideas?

Thanks :)
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
As far as I know there is no way to change the orientation of how the data is copied from the recordset.

Why do you need to anyway?

If you do need to manipulate the data then you'll probably need to do it after it's been copied to the worksheet.

Perhaps you should be looking into transposing it?
 
Upvote 0
Try this:

Code:
Dim vArr As Variant

vArr = oRS.GetRows()

oRange.Resize(UBound(vArr,1),UBound(vArr,2).Value = vArr

In place of the line

Call oRange.CopyFromRecordset(oRS)
 
Upvote 0
You could load an array with the recordset, e.g. oRS.GetRows, and then unoad the array into a range using Transpose.
 
Upvote 0
thanks for trying... Just trying to work out what that code does. Not come across many of these excel functions before, this is the first time i've coded with excel.

I get "Application-defined or object defined error"

using office 2007.

:)
 
Upvote 0
Code:
Global g_sConnectionString As String
' Declares for INI Get & Put commands
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal grpnm As Any, ByVal parnm As Any, ByVal deflt As String, ByVal parvl As String, ByVal parlen As Long, ByVal INIPath As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal grpnm As String, ByVal parnm As Any, ByVal parvl As Any, ByVal INIPath As String) As Long

Public Function GetINI(ByVal sINIFile As String, ByVal sSection As String, ByVal sKey As String, ByVal sDefault As String) As String

    ' Declare local variables
    Dim lCode As Long
    Dim sBuff As String * 4096
    
    If sINIFile = "" Or sSection = "" Or sKey = "" Then
        GetINI = ""
        Exit Function
    End If
    
    ' Call API routine - length of result is returned in lRCLength
    lCode = GetPrivateProfileString(sSection, sKey, sDefault, sBuff, Len(sBuff), sINIFile)
    
    ' Trim of the excess and return the rest in GetValue
    GetINI = Left$(sBuff, lCode)


End Function
Function FileExists(ByVal sFileName As String) As Boolean

On Error GoTo Deverr:
If sFileName = "" Then
    FileExists = False
    Exit Function
End If

FileExists = (Dir(sFileName, 0) <> "")
FileExists = (Dir(sFileName, vbHidden) <> "")

Exit Function

Deverr:
    FileExists = False
    Exit Function

End Function
Public Function PutINI(ByVal sINIFile As String, ByVal sSection As String, ByVal sKey As String, ByVal sValue As String) As Boolean

    Dim lCode As Long
    PutINI = False
    
    If sINIFile = "" Or sSection = "" Or sKey = "" Then
        Exit Function
    End If
    
    ' Call API routine - lRCResult will be non-zero if succesful
    lCode = WritePrivateProfileString(sSection, sKey, sValue, sINIFile)

    If lCode <> 0 Then
        PutINI = True
    End If

End Function


Function GetConnectionString() As Boolean


    Dim sINI As String
    sINI = "\\blah\blah\blah.INI"

    g_sConnectionString = GetINI(sINI, "Reports", "ConnectionString", "")



    If g_sConnectionString = "" Then
        MsgBox "ERROR - Could not connect to reports data", vbExclamation, "Get Data"
        GetConnectionString = False
        Exit Function
    End If


    GetConnectionString = True

End Function
Sub cmdRefresh()

    If GetConnectionString = False Then
        Exit Sub
    End If



    Dim oWorkbook As Workbook
    Dim oWorksheet As Worksheet
    Dim oRange As Range
    Dim oRS As ADODB.Recordset
    
    
    Set oWorkbook = ActiveWorkbook
    
    
    ' Get SQL String
    Set oWorksheet = oWorkbook.Worksheets("SQL")
    Set oRange = oWorksheet.Range("A1")
    Dim sSQL As String
    sSQL = Trim(oRange.Value)
    On Error Resume Next
    Set oRS = modMain.GetSQLData(sSQL)
    If Err <> 0 Then
        MsgBox "Problem retrieving data : " & Err.Description, vbExclamation, "Get Data"
        Exit Sub
    End If
    On Error GoTo 0
    
    
    
    Set oWorksheet = oWorkbook.Worksheets("Data")
    Set oRange = oWorksheet.Range("B1")

    Dim vArr As Variant

    vArr = oRS.GetRows()

    oRange.Resize(UBound(vArr, 1), UBound(vArr, 2)).Value = vArr
    oRS.Close
    
    
    Set oWorksheet = oWorkbook.Worksheets("Summary")
    
    Dim oPT As PivotTable
    For Each oPT In oWorksheet.PivotTables
        oPT.RefreshTable
    Next
    
    
    
    
    
End Sub

Function GetSQLData(ByVal sSQL As String) As ADODB.Recordset



    Dim oConn As New ADODB.Connection
    Dim oRSOut As ADODB.Recordset
    
    
    If sSQL = "" Then
        Exit Function
    End If
    
    
    On Error Resume Next
    With oConn
        .CursorLocation = adUseClient 'suspect
        .Open g_sConnectionString
        .CommandTimeout = 0
       Set oRSOut = .Execute(sSQL)
    End With
    If Err <> 0 Then
        Exit Function
    End If
    On Error GoTo 0

    Set GetSQLData = oRSOut
   
    Set oRSOut = Nothing
    Set oConn = Nothing

End Function

errors on line:
oRange.Resize(UBound(vArr, 1), UBound(vArr, 2)).Value = vArr
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,240
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top