Write ADO SQL results to Userform Spreadsheet1 control

[stapuff]

I have the following working. The code between the *** is what I am looking to change. I would prefer writing the result of the SQL directly to my userform spreadsheet control rather than sending it to a worksheet then pasting it to the spreadsheet control.

Any help would be appreciated.

Thanks,

Kurt



Public Sub PopulateSpreadsheet()
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim MySQLcheck As String
Dim intFieldCount, i As Integer

Set cnn = New ADODB.Connection
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=S:\Sunkist\Sunkist.mdb"

MySQLcheck = "select * from XXXFG_Leadtime where WH_From = '" & UF_WorkOrder.MultiPage1(1).oCB1.Value & "';"

Set rst = cnn.Execute(MySQLcheck)

intFieldCount = rst.Fields.Count
rst.MoveFirst

'*****************************************************
Sheet1.Cells.ClearContents
For i = 0 To intFieldCount - 1
With Sheet1.Range("A1").Offset(0, i)
.Value = rst.Fields(i).Name
End With
Next
'*****************************************************
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
End Sub

[Bob Phillips]

'*****************************************************
Sheet1.Cells.ClearContents
For i = 0 To intFieldCount - 1
With Sheet1.Range("A1").Offset(0, i)
Userform1.Controls("TextBox" & i).Text = rst.Fields(i).Name
End With
Next
'*****************************************************


Does this mean that the other thread is dead?

[stapuff]

Xld -

I have a Spreadsheet1 control on a Userform. I want to see it I can get the result from the SQL directly on UF_WorkOrder.MultiPage1(1).Spreadsheet1 not on an activesheet.

I'm not sure how to apply your code to that.

Kurt

The other is still open.

[Bob Phillips]

I have never used the spreadsheet control, so can yoiu show me how you load it, and I am sure I can do the rest.

[stapuff]

Xld - I appreciate you looking at this.
These are the steps I tak in order. As you can see - piece 1 calls it, piece 2 puts it into a worksheet range, & the third does a simple copy paste.


Private Sub oTB2_AfterUpdate()
Me.oTB3.Value = Format(Date, "mm / dd / yyyy")
Me.oTB3.Visible = True
Me.oLbl6.Visible = True
Me.oTB4.Visible = True
Me.oLbl7.Visible = True
Call PopulateSpreadsheet
Call GetRecords
Call CleanupFill
Me.oTB5.Visible = True
Me.oLbl8.Visible = True
Me.oTB5.SetFocus
End Sub


Public Sub PopulateSpreadsheet()
On Error GoTo UserForm_Initialize_Err
Dim intFieldCount, I As Integer
Set cnn = New ADODB.Connection
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=S:\Sunkist\Sunkist.mdb"
MySQLcheck = "select * from XXXFG_Leadtime where WH_From = '" & UF_WorkOrder.MultiPage1(1).oCB1.Value & "';"
Set rst = cnn.Execute(MySQLcheck)
intFieldCount = rst.Fields.Count
rst.MoveFirst
Sheet1.Cells.ClearContents
For I = 0 To intFieldCount - 1
With Sheet1.Range("A1").Offset(0, I)
.Value = rst.Fields(I).Name
End With
Next


UserForm_Initialize_Exit:
On Error Resume Next
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
Exit Sub
UserForm_Initialize_Err:
' MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, "Error!"
Resume UserForm_Initialize_Exit
End Sub



Public Sub GetRecords()
Dim rngTarget As Range
MySQLcheck = "SELECT [WH_From],[WH_To],[Total_Days_Req],[To_Schedule],[Production_Days],[QA_Incubation],[Load_Time],[On_Water],[Truck_To_Whse] from XXXFG_Leadtime where [WH_From] = '" & UF_WorkOrder.MultiPage1(1).oCB1.Value & "' AND [WH_To] = '" & UF_WorkOrder.MultiPage1(1).oCB2.Value & "';"
Set rngTarget = ActiveSheet.Range("A2")
Call RetrieveRecordset(MySQLcheck, rngTarget)
End Sub



Public Sub CleanupFill()
Sheet1.Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Replace What:="_", Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Sheet1.Range("A1").Select
Range(Selection.End(xlDown), Selection.End(xlToRight)).Select
Selection.Copy
With Application
.ScreenUpdating = False
With UF_WorkOrder.MultiPage1(1).oSpreadsheet1.ActiveSheet
.Range("A1").Paste
.Range("A1").Select
.Columns.AutoFitColumns
End With
.CutCopyMode = False
.ScreenUpdating = True
DoEvents
End With
End Sub


Public Sub RetrieveRecordset(MySQLcheck As String, clTrgt As Range)
Dim cnt As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim rcArray As Variant
Dim lFields As Long
Dim lRecrds As Long
Dim lCol As Long
Dim lRow As Long
cnt.Open glob_sConnect
rst.Open MySQLcheck, cnt

lFields = rst.Fields.Count
If Val(Mid(Application.Version, 1, InStr(1, Application.Version, ".") - 1)) > 8 Then
On Error Resume Next
clTrgt.CopyFromRecordset rst

If Err.Number <> 0 Then GoTo EarlyExit

Else
rcArray = rst.GetRows
lRecrds = UBound(rcArray, 2) + 1
For lCol = 0 To lFields - 1
For lRow = 0 To lRecrds - 1

If IsDate(rcArray(lCol, lRow)) Then
rcArray(lCol, lRow) = Format(rcArray(lCol, lRow))

ElseIf IsArray(rcArray(lCol, lRow)) Then
rcArray(lCol, lRow) = "Array Field"
End If
Next lRow
Next lCol

clTrgt.Resize(lRecrds, lFields).Value = TransposeDim(rcArray)
End If
EarlyExit:

rst.Close
cnt.Close
Set rst = Nothing
Set cnt = Nothing
On Error GoTo 0
End Sub
Private Function TransposeDim(V As Variant) As Variant
Dim x As Long, Y As Long, Xupper As Long, Yupper As Long
Dim tempArray As Variant
Xupper = UBound(V, 2)
Yupper = UBound(V, 1)
ReDim tempArray(Xupper, Yupper)
For x = 0 To Xupper
For Y = 0 To Yupper
tempArray(x, Y) = V(Y, x)
Next Y
Next x
TransposeDim = tempArray
End Function

[Bob Phillips]

Wow. That surprised me.

To help us even more can you post the wband the mdb.

[stapuff]

8105

[stapuff]

Xld -

Again - Thanks!

I'm working on the .mdb zip

[stapuff]

Here is the .mdb zip.

8106

[Bob Phillips]

Can you give me a list of values to plug in, and what you want to see where please?

[stapuff]

Xld -

1 On UF start up click "Work Order" button
2 The Multipage should show. Select "Open Work Order" page
3 CB1 - L6
4 CB2 - KP
5 CB3 - MOA108
6 TB1(Qty) - 500
7 TB4(W/O #) 999999 - tab out
You will see the userform.spreadsheet control show filled. This is writing the data to the activework book sheet then copying/pasteing to the UF Spreadsheet control. Can I have the Spreadsheet control updated without the Copy/Paste. Updated directly via code. This is currently being done in the Public Sub CleanupFill

[stapuff]

Well - I've finally figured this out. I would like to see if someone could make this better, but it works for now.

Points of interest -
In the first ADO - in order to get the count of records in your database - you need to adOpenStatic or it error's out.

If you have your spreadsheet1 hide the code will error out. You must unhide prior to filling it in.
Me.oSpreadsheet1.Visible = True

I wanted my .mdb column names as my spreadsheets top row so you need to use Field Names.




Private Sub SpreadsheetFill()
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim MySQLcheck As String
Dim i, j As Long
Dim FieldCount, RowCount As Integer
Set rst = New ADODB.Recordset
Set cnn = New ADODB.Connection
MySQLcheck = "Select * from XXXFG_Leadtime"
With cnn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Data Source=F:\Open Projects\Sunkist.mdb;"
.Open
End With

rst.Open MySQLcheck, cnn, adOpenStatic
RowCount = (rst.RecordCount)
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing

Set cnn = New ADODB.Connection
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=F:\Open Projects\Sunkist.mdb"
MySQLcheck = "SELECT [WH_From],[WH_To],[Total_Days_Req],[To_Schedule],[Production_Days],[QA_Incubation],[Load_Time],[On_Water],[Truck_To_Whse] from XXXFG_Leadtime where [WH_From] = '" & UF_WorkOrder.MultiPage1(1).oCB1.Value & "' AND [WH_To] = '" & UF_WorkOrder.MultiPage1(1).oCB2.Value & "';"
Set rst = cnn.Execute(MySQLcheck)
FieldCount = (rst.Fields.Count)
rst.MoveFirst
Me.oSpreadsheet1.Visible = True
Me.oSpreadsheet1.SetFocus
For i = 0 To FieldCount - 1
With Me.oSpreadsheet1.Cells(1, 1).Offset(0, i)
.Value = rst.Fields(i).Name
End With
Next i
rst.MoveFirst
For j = 0 To RowCount - RowCount '(This will return a single record. Replace -RowCount with -1 if you have more than 1 record)
For i = 0 To FieldCount - 1
With Me.oSpreadsheet1.Cells(j + 2, 1).Offset(0, i)
.Value = rst.Fields(i).Value
End With
Next i
rst.MoveNext
Next j
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
End Sub