PDA

View Full Version : [SOLVED] Transpose ADO import



jo15765
09-18-2012, 07:01 AM
I am running the below code as an ADO import:


Public Sub Import()
Const strDb As String = "C:\Test\Test1.mdb"
Const strQry As String = "SELECT email FROM tblCustomerInfo"
Dim rs As ADODB.Recordset
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & strDb & ";"
Set rs = New ADODB.Recordset
With rs
Set .ActiveConnection = cn
.Open strQry
End With
Worksheets("Sheet1").Range("A1").CopyFromRecordset rs
'Transpose:=True
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing
End Sub

My question is, how do I transpose the data that is being imported to go across row 1 instead of down Column A?

EDIT:
This code would be for Excel 2000 also.

snb
09-18-2012, 07:41 AM
Sub snb()
With New Recordset
.Open "SELECT email FROM tblCustomerInfo", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Test\Test1.mdb"
Sheets(1).Cells(1).CopyFromRecordset .DataSource
With Sheets(1).Cells(1).CurrentRegion
Sheets(1).Cells(1).Resize(.Columns.Count, .Rows.Count) = Application.Transpose(.Value)
End With
End With
End Sub

jo15765
09-18-2012, 07:57 AM
Sub snb()
With New Recordset
.Open "SELECT email FROM tblCustomerInfo;", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source='" & "C:\Test\Test1.mdb'"
Sheets(1).Cells(1).CopyFromRecordset .DataSource
With Sheets(1).Cells(1).CurrentRegion
Sheets(1).Cells(1).Resize(.Columns.Count, .Rows.Count) = Application.Transpose(.Value)
End With
End With
End Sub

Thank you for the quick reply! I am getting a debug error of invalid use of "New" Keyword on the 1st line of the code?

snb
09-18-2012, 07:59 AM
You will have to add the reference to the ADO library
VBEditor/Extra/references

Microsoft ActiveX DataObjects 2.0 Library

jo15765
09-18-2012, 08:04 AM
I thought that was a full procedure, I adapted it to this:


Dim rs As ADODB.recordset
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
Set rs = New ADODB.recordset
With New Recordset
.Open "SELECT email FROM tblCustomerInfo;", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source='" & "C:\Test\Test1.mdb'"
Sheets(1).Cells(1).CopyFromRecordset .DataSource
With Sheets(1).Cells(1).CurrentRegion
Sheets(1).Cells(1).Resize(.Columns.Count, .Rows.Count) = Application.Transpose(.Value)
End With
End With


It seems to be stopping the copy to transpose at the 1st blank..there are a few gaps here and there is it possible to transpose all the data including below the gaps?

snb
09-18-2012, 08:09 AM
The use of any variable in this code is redundant.
You can see that you do not need the variables rs or cn to import the data.

if you use an empty sheet this will suffice


Sub snb()
With New Recordset
.Open "SELECT email FROM tblCustomerInfo", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Test\Test1.mdb"
Sheets(1).Cells(1).CopyFromRecordset .DataSource
End With
Sheets(1).Cells(1).Resize(Sheets(1).usedrange.Columns.Count, Sheets(1).usedrange.Rows.Count) = Application.Transpose(Sheets(1).usedrange.Value)
End Sub


or you can adapt the sql-string so no empty records will be imported.

jo15765
09-18-2012, 08:12 AM
The use of any variable in this code is redundant.

if you use an empty sheet this will suffice


Sub snb()
With New Recordset
.Open "SELECT email FROM tblCustomerInfo", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Test\Test1.mdb"
Sheets(1).Cells(1).CopyFromRecordset .DataSource
With Sheets(1).usedrange
Sheets(1).Cells(1).Resize(.Columns.Count, .Rows.Count) = Application.Transpose(.Value)
End With
End With
End Sub

or you can adapt the sql-string so no empty records will be imported.
On my end it is still stopping the transpose at the 1st gap?

snb
09-18-2012, 08:19 AM
You must be 'working at the "wrong" end' ;)

I can't tell without seeing the worksheet.
What does it look like before the transpose: how many records ?, how many fields ?
The method 'Transpose' has it's limitations.

jo15765
09-18-2012, 08:25 AM
The results returned by the initial ADO import (including blanks) is 122 rows...the transpose only takes the 1st 11 rows (stopping at the 1st blank)

snb
09-18-2012, 08:34 AM
Sub snb()
With New Recordset
.Open "SELECT email FROM tblCustomerInfo", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Test\Test1.mdb"
Sheets(1).Cells(1).CopyFromRecordset .DataSource
End With
sheets(1).cells(1).resize(,sheets(1).cells.specialcells(11).row)=applicatio n.transpose(sheets(1).cells(1).resize(sheets(1).cells.specialcells(11).row) .value)
End Sub

jo15765
09-18-2012, 08:38 AM
Running that code I get a debug error of

Unable to get the SpecialCells property of the Range Class

I ran it with and w/o the extra comma:


sheets(1).cells(1).resize(,sheets(1).cells.specialcells(16).row)=applicatio n.transpose(sheets(1).cells(1).resize(sheets(1).cells.specialcells(16).row) .value)




sheets(1).cells(1).resize(sheets(1).cells.specialcells(16).row)=application .transpose(sheets(1).cells(1).resize(sheets(1).cells.specialcells(16).row). value)

snb
09-18-2012, 08:42 AM
I amended my code: 16 should be 11.

see my post #10.

jo15765
09-18-2012, 08:46 AM
By George you did it!! Thank you tremendously!

One more tweak if possible...How can I have the transpose begin in row 1 of Column AB?

snb
09-18-2012, 08:58 AM
Sub snb()
' set reference to Microsoft ActveX Data Objects 2.0 Library
With New Recordset
.Open "SELECT email FROM tblCustomerInfo", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Test\Test1.mdb"
Sheets(1).Cells(1).CopyFromRecordset .DataSource
End With
sheets(1).cells(1,28).resize(,sheets(1).cells.specialcells(11).row)=applica tion.transpose(sheets(1).cells(1).resize(sheets(1).cells.specialcells(11).r ow).value)
End Sub

NB. compare this to the amount of code you started with.....

jo15765
09-18-2012, 09:03 AM
Sub snb()
' set reference to Microsoft ActveX Data Objects 2.0 Library

With New Recordset
.Open "SELECT email FROM tblCustomerInfo", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Test\Test1.mdb"
Sheets(1).Cells(1).CopyFromRecordset .DataSource
End With
sheets(1).cells(1,28).resize(,sheets(1).cells.specialcells(11).row)=applica tion.transpose(sheets(1).cells(1).resize(sheets(1).cells.specialcells(11).r ow).value)
End Sub
NB. compare this to the amount of code you started with.....

Perfect thank you!

Aflatoon
09-19-2012, 04:19 AM
BTW you could also use the recordset's GetRows method since it returns a transposed recordset anyway. :)

johnywhy
10-04-2021, 09:09 AM
Sub snb()
With New Recordset
.Open "SELECT email FROM tblCustomerInfo", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Test\Test1.mdb"
Sheets(1).Cells(1).CopyFromRecordset .DataSource
End With
sheets(1).cells(1,28).resize(,sheets(1).cells.specialcells(11).row)=applica tion.transpose(sheets(1).cells(1).resize(sheets(1).cells.specialcells(11).r ow).value)
End Sub


It looks like your pushing the data to the sheet, and then transposing it. I believe that's not the most efficient approach.


Dim oRs As New Recordset
oRs.Open "SELECT email FROM tblCustomerInfo", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Test\Test1.mdb"
Dim vRecs
vRecs = oRs.GetRows
Dim vRecsX
vRecsX = WorksheetFunction.Transpose(vRecs)
Sheet3.Range("D5").Resize(oRs.RecordCount, oRs.Fields.Count) = vRecsX

https://www.snb-vba.eu/VBA_ADODB_recordset_en.html#L_12.2