Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

vba ADODB connection no header

Posted on 2016-08-15
5
Medium Priority
?
223 Views
Last Modified: 2016-08-17
I have a successful connection and data pull, but I do not get the headers.
Can someone help with with the code to pull the headers into excel row 1?

Sub RunReport()

Dim ws As Worksheet
    
    For Each ws In ActiveWorkbook.Worksheets
        ws.Visible = xlSheetVisible
    Next ws

Sheets("Shipment Data").Select
Range("A2:EZ1048576").Select
Selection.ClearContents


Dim cn As ADODB.Connection
Set cn = New ADODB.Connection

Dim DSN As String

Dim Password As Variant

If Sheets("Queries").Range("G5").Value = True Then Password = InputBox("Please enter your password here:") Else Password = ""

DSN = Sheets("Selection").Range("C2")

cn.Open "DSN=" & DSN & ";password =" & Password & "; ConnectionTimeout=0;"

Dim Query As String

Query = Sheets("Queries").Range("E2").Value

Dim rs As New ADODB.Recordset
Dim cmd As New ADODB.Command
Set rs = New ADODB.Recordset
Set cmd = New ADODB.Command

cmd.ActiveConnection = cn
cmd.CommandTimeout = 0
cmd.CommandText = Query

Set rs = cmd.Execute()
Sheets("Shipment Data").Range("A2").CopyFromRecordset rs
Set rs = Nothing

cn.Close
Set con = Nothing


Dim ShipSheet As Worksheet
Dim ShipDataRange As Range
Dim NewRange1 As String
Dim LastShipRow As Long

Set ShipSheet = Sheets("Shipment Data")

LastShipRow = ShipSheet.Cells(Rows.Count, "A").End(xlUp).Row

Set ShipDataRange = ShipSheet.Range(ShipSheet.Cells(1, "A"), ShipSheet.Cells(LastShipRow, "CF"))
  
NewRange1 = ShipSheet.Name & "!" & _
ShipDataRange.Address(ReferenceStyle:=xlR1C1)



 ActiveSheet.Range("A5").CopyFromRecordset objMyRecordset
 Range("A4").Select
    
Dim pt As PivotTable

For Each ws In ActiveWorkbook.Worksheets
    If ws.Tab.Color = RGB(255, 193, 153) Then
    For Each pt In ws.PivotTables
    pt.ChangePivotCache _
    ThisWorkbook.PivotCaches.Create( _
    SourceType:=xlDatabase, _
    SourceData:=NewRange1)
    Next pt
    End If
Next ws

Sheets("Queries").Visible = False

If Sheets("Queries").Range("H18").Value = True Then
Dim strFilename As String
strFilename = Sheets("Queries").Range("H19").Value
ActiveWorkbook.SaveAs Filename:=strFilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Else
End If


End Sub

Open in new window

0
Comment
Question by:Euro5
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 3
  • 2
5 Comments
 
LVL 46

Expert Comment

by:aikimark
ID: 41756628
CopyFromRecordset only transfers the data.  You will need to iterate the fields and transfer each field's name to get the headers you desire.
0
 

Author Comment

by:Euro5
ID: 41756744
aikimark
Can you help me with that?
0
 
LVL 46

Accepted Solution

by:
aikimark earned 2000 total points
ID: 41756769
Set ShipDataRange = Sheets("Shipment Data").Range("A1")
For Each fld in rs.Fields
    ShipDataRange.Value = fld.Name
    Set ShipDataRange = ShipDataRange.Offset(0,1)
Next

Open in new window

0
 

Author Comment

by:Euro5
ID: 41756793
I have tried many variations and still none work.
When I put yours in it still doesn't work...
Sub RunReport()

Dim ws As Worksheet
    
    For Each ws In ActiveWorkbook.Worksheets
        ws.Visible = xlSheetVisible
    Next ws

Sheets("Shipment Data").Select
Range("A2:EZ1048576").Select
Selection.ClearContents


Dim cn As ADODB.Connection
Set cn = New ADODB.Connection

Dim DSN As String

Dim Password As Variant

If Sheets("Queries").Range("G5").Value = True Then Password = InputBox("Please enter your password here:") Else Password = ""

DSN = Sheets("Selection").Range("C2")

cn.Open "DSN=" & DSN & ";password =" & Password & "; ConnectionTimeout=0;"

Dim Query As String

Query = Sheets("Queries").Range("E2").Value

Dim rs As New ADODB.Recordset
Dim cmd As New ADODB.Command
Set rs = New ADODB.Recordset
Set cmd = New ADODB.Command

    
cmd.ActiveConnection = cn
cmd.CommandTimeout = 0
cmd.CommandText = Query

Set rs = cmd.Execute()
Sheets("Shipment Data").Range("A2").CopyFromRecordset rs
Set rs = Nothing

cn.Close
Set con = Nothing

Set ShipDataRange = Sheets("Shipment Data").Range("A1")
For Each fld In rs.Fields
    ShipDataRange.Value = fld.Name
    Set ShipDataRange = ShipDataRange.Offset(0, 1)
Next


Dim ShipSheet As Worksheet
Dim ShipDataRange As Range
Dim NewRange1 As String
Dim LastShipRow As Long

Set ShipSheet = Sheets("Shipment Data")

LastShipRow = ShipSheet.Cells(Rows.Count, "A").End(xlUp).Row

Set ShipDataRange = ShipSheet.Range(ShipSheet.Cells(1, "A"), ShipSheet.Cells(LastShipRow, "CF"))
  
NewRange1 = ShipSheet.Name & "!" & _
ShipDataRange.Address(ReferenceStyle:=xlR1C1)

    
Dim pt As PivotTable

For Each ws In ActiveWorkbook.Worksheets
    If ws.Tab.Color = RGB(255, 193, 153) Then
    For Each pt In ws.PivotTables
    pt.ChangePivotCache _
    ThisWorkbook.PivotCaches.Create( _
    SourceType:=xlDatabase, _
    SourceData:=NewRange1)
    Next pt
    End If
Next ws

Sheets("Queries").Visible = False

If Sheets("Queries").Range("H18").Value = True Then
Dim strFilename As String
strFilename = Sheets("Queries").Range("H19").Value
ActiveWorkbook.SaveAs Filename:=strFilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Else
End If


End Sub

Open in new window

0
 
LVL 46

Expert Comment

by:aikimark
ID: 41759942
When I put yours in it still doesn't work...
If that is the case, why did you accept my comment as the solution?
0

Featured Post

Moving data to the cloud? Find out if you’re ready

Before moving to the cloud, it is important to carefully define your db needs, plan for the migration & understand prod. environment. This wp explains how to define what you need from a cloud provider, plan for the migration & what putting a cloud solution into practice entails.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This post looks at MongoDB and MySQL, and covers high-level MongoDB strengths, weaknesses, features, and uses from the perspective of an SQL user.
This article shows how to get a list of available printers for display in a drop-down list, and then to use the selected printer to print an Access report or a Word document filled with Access data, using different syntax as needed for working with …
Video by: Steve
Using examples as well as descriptions, step through each of the common simple join types, explaining differences in syntax, differences in expected outputs and showing how the queries run along with the actual outputs based upon a simple set of dem…
In this video, Percona Solution Engineer Dimitri Vanoverbeke discusses why you want to use at least three nodes in a database cluster. To discuss how Percona Consulting can help with your design and architecture needs for your database and infras…

721 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question