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 :)
 

Some videos you may like

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,218
Office Version
  1. 365
Platform
  1. Windows
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?
 

Richard Schollar

MrExcel MVP
Joined
Apr 19, 2005
Messages
23,707
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)
 

Jon von der Heyden

MrExcel MVP, Moderator
Joined
Apr 6, 2004
Messages
10,808
Office Version
  1. 365
Platform
  1. Windows
You could load an array with the recordset, e.g. oRS.GetRows, and then unoad the array into a range using Transpose.
 

joesef

Board Regular
Joined
Sep 5, 2008
Messages
189

ADVERTISEMENT

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)

Thanks for the input guys.

is there a closing bracket missing there?

:)
 

joesef

Board Regular
Joined
Sep 5, 2008
Messages
189

ADVERTISEMENT

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.

:)
 

Richard Schollar

MrExcel MVP
Joined
Apr 19, 2005
Messages
23,707
Can you post the entire code you are using and indicate on which exact line you get the error.
 

joesef

Board Regular
Joined
Sep 5, 2008
Messages
189
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
 

Watch MrExcel Video

Forum statistics

Threads
1,122,803
Messages
5,598,131
Members
414,214
Latest member
marketingnumbersguy

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
Top