CopyFromRecordset

[Bam]

Hi All,

I'm having an issue where I would like to return all records based on a
cell, and copy them across columns until they stop finding a matching record.

The Select statement may return up to 4 or 5 values, but it is only using
the last value it finds, then moves down to the next row.

I want the 3 Fields for each record found to be put into the same row as the
strTargetStock, and keep repeating across the columns until the last record
is found.

I'm sure this is easy, but i've not been able to figure it out.
Any help would be appreciated.

Cheers,
Bam.

Option Explicit

Private con As Object
Private rst As Object

Sub ADOData(sSQL As String, rg As Range)
Dim sConn As String
Dim sheet As Worksheet
Dim ws As Worksheet
Set ws = ActiveSheet

On Error GoTo ErrHandler

'Create a new recordset object
Set con = CreateObject("ADODB.Connection")
'Set con = New ADODB.Connection
con.Open "Driver={SQL
Server};Server=SERVER;Database=DB171;Uid=USER;Pwd=PASSWORD;"

Set rst = CreateObject("ADODB.Recordset")

Set rst = con.Execute(sSQL, , 1)

rg.CopyFromRecordset rst

rst.Close

con.Close

'Clean up.
Set rst = Nothing
Set rg = Nothing
Exit Sub
ErrHandler:
MsgBox "Sorry,an error occured." & Err.Description & " " & sSQL, vbOKOnly

End Sub

Sub Customer()

Dim i As Integer
Dim c As Integer
Dim j As Byte
Dim intHowManyRow As Integer
Dim intStartRow As Integer
Dim intEndRow As Integer
Dim strTargetStock As String
Dim Customer As String
Dim DelCode As String
Dim Mysht As Worksheet

Set Mysht = ActiveSheet

intHowManyRow = Mysht.UsedRange.Rows.Count
intStartRow = 2
c = 3
intEndRow = intStartRow + intHowManyRow - 1
Range("C1") = "LM Code"
Range("D1") = "Width"
Range("E1") = "Length"
For i = intStartRow To intEndRow
strTargetStock = RTrim(LTrim((Cells(i, 1))))
Application.ScreenUpdating = False
Cells(i, 3).Select
'Call Data
If strTargetStock <> "" Then
Call ADOData("SELECT IM_STOCK, IM_WIDE, IM_LEN " & _
"FROM IMI1 WITH (NOLOCK) " & _
"WHERE IM_CUST_STOCK = ('" & strTargetStock & "') AND
(IM_ACTIVE = 1)", Cells(i, c))
End If
Application.ScreenUpdating = True
Next i

ActiveCell.Select

End Sub

 

[Joel]

You need something like this

set rs.open "enter your SQL statements here"
Rowcount = 1
Do until rs.Eof
ColCount = 1
for each fld in rs.Fields
Cells(RowCount,ColCount)
ColCount = ColCount + 1
next fld
rs.movenext
Rowcount = RowCount + 1
Loop

 

[Patrick Molloy]

I'm not really sure what you need. It sounds like you're requesting too many
fields if you only need three, then select just those three.
If you're looking at filtering for specific values in a certain field, then
the recordset has a filter method

eg where rst is an ADODB.Recordset object
rst.Filter = "stockNum=' & Range(stocknum) & " '"

so if your recordset has 1000 records, your filter may result in a subset of
these. Were you to use the range CopyFromRecordset now, you would get the
filtered result only.

does this help?

 

[Bam]

Hi Patrick,

I'm currently returning 3 fields for each row. These 3 fields go into
Columns C,D & E. When i get multiple results, they return each record down.
So say I return 2 results, then the 1st result goes into the ActiveRow (Row
2) & the next result goes into the row underneath. (Row 3)

Then the selection process goes to Row 3, and overwrites it.

My problem is the i need to record all results returned from the select
statement, in that same row. So if i get 2 results, i'd like the 2nd result
to go into F, G & H. 3 Results, the 3rd goes into I, J & K.

If i get 3 results, then i would have populated columns C through to K with
with 3 fields for each result.

I've tried all day to use Joels solution, which makes sense, but i just
can't get it to work.

Any help would be great.

Thanks.

Bam.

 

[norie]

Why not just get the whole recordset with one query and then
manipulate the results using Excel VBA?

 

[Patrick Molloy]

code then would be record by record I'm afraid. I tried the worksheet
TRANSPOSE function but it failed

rst.MoveFirst
With rst
Do Until .EOF
For item = 0 To .Fields.Count - 1
target.Offset(item) = .Fields(item)
Next
.MoveNext
Set target = target.Offset(, 1)
Loop
End With


what you could do is a copyfromrecordset to a temp sheet then a pastespecial
transpose...

Set ws = Worksheets.Add
rst.MoveFirst
Set target = ws.Range("A1")
target.CopyFromRecordset rst

target.CurrentRegion.Resize(200).Copy
Worksheets("sheet10").Range("A1").PasteSpecial Paste:=xlPasteAll,
Transpose:=True
application.displayalerts=false
ws.delete

 

[Bam]

Norie,

I think i am though.

I have a module containing the ADO setup which is then called by a 2nd module.

Option Explicit

Private con As Object
Private rst As Object

Sub ADOData(sSQL As String, rg As Range)
Dim sConn As String
Dim c As Integer
Dim sheet As Worksheet
Set sheet = ActiveSheet

On Error GoTo ErrHandler

'Create a new recordset object
Set con = CreateObject("ADODB.Connection")
'Set con = New ADODB.Connection
con.Open "Driver={SQL
Server};Server=SERVER;Database=PWIN171;Uid=READER;Pwd=PASS;"

Set rst = CreateObject("ADODB.Recordset")

Set rst = con.Execute(sSQL, , 1)

rg.CopyFromRecordset rst

rst.Close

con.Close

'Clean up.
Set rst = Nothing
Set rg = Nothing
Exit Sub
ErrHandler:
MsgBox "Sorry,an error occured." & Err.Description & " " & sSQL, vbOKOnly

End Sub


2nd Module.

Sub Parmalat()

Dim i As Integer
Dim c As Integer
Dim intHowManyRow As Integer
Dim intStartRow As Integer
Dim intEndRow As Integer
Dim strTargetStock As String
Dim Mysht As Worksheet

Set Mysht = ActiveSheet

intHowManyRow = Mysht.UsedRange.Rows.Count
intStartRow = 2
c = 3
intEndRow = intStartRow + intHowManyRow - 1
Range("C1") = "LM Code"
Range("D1") = "Width"
Range("E1") = "Length"

Application.ScreenUpdating = True

For i = intStartRow To intEndRow
strTargetStock = RTrim(LTrim((Cells(i, 1))))
c = 3
Cells(i, c).Select
If strTargetStock <> "" Then
Call ADOData("SELECT IM_STOCK, IM_WIDE, IM_LEN " & _
"FROM IMI1 WITH (NOLOCK) " & _
"WHERE IM_CUST_STOCK = ('" & strTargetStock & "') AND
(IM_ACTIVE = 1)", Cells(i, c))
End If
Next i

ActiveCell.Select

End Sub


I adadpt this same setup for each spreadsheet that requires it, however i
just can't get my head around how to do it this way?
Eg: Find all records that match Cells(2, 1) - Put Matching records across
columns, move down to next row, go again..

Cheers,

Bam.

 

[Bam]

Hi All,

Well, i've mucked around with and finally got the solution... Thanks for the
main part of the code Patrick. I got it off one of your other posts.

Option Explicit

Private db As Object
Private rst As Object

Sub LoadFromSQL()
Dim SQL As String
Dim Mysht As Worksheet
Dim i As Integer
Dim c As Integer
Dim Item As Integer
Dim intHowManyRow As Integer
Dim intStartRow As Integer
Dim intEndRow As Integer
Dim strTargetStock As String
Dim Target As Range
Set Mysht = ActiveSheet

intHowManyRow = Mysht.UsedRange.Rows.Count
intStartRow = 2

intEndRow = intStartRow + intHowManyRow - 1
Range("C1") = "LM Code"
Range("D1") = "Width"
Range("E1") = "Length"

Application.ScreenUpdating = True

'On Error GoTo ErrHandler

For i = intStartRow To intEndRow
c = 3
strTargetStock = "%" + RTrim(LTrim((Cells(i, 1)))) + "%"
Cells(i, c).Select

' CREATE AND OPEN A CONNECTION TO THE DATABASE
Set db = CreateObject("ADODB.Connection")
With db
'.CursorLocation = adUseClient
.Open "Driver={SQL
Server};Server=SERVER;Database=DB;Uid=USER;Pwd=PWD;"
End With

'CREATE AND POPULATE THE RECORDSET
Set rst = CreateObject("ADODB.Recordset")
SQL = "SELECT IM_STOCK, IM_WIDE, IM_LEN " & _
"FROM IM WITH (NOLOCK) " & _
"WHERE (IM_CUST_STOCK LIKE '" & strTargetStock
& "') AND (IM_ACTIVE = 1)"

rst.Open SQL, db
Set Target = Mysht.Cells(i, c)

'DROP RESULTS INTO A SPREADSHEET
With rst
Do Until .EOF
For Item = 0 To .Fields.Count - 1
Target.Offset(0, Item) = .Fields(Item)
Next
.MoveNext
Set Target = Target.Offset(, 3)
Loop
End With

'CLEAN UP
rst.Close
db.Close
Set rst = Nothing
Set db = Nothing

Next i

Exit Sub

ErrHandler:
MsgBox "Sorry,an error occured." & Err.Description & " " & SQL, vbOKOnly


End Sub