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