JoeGKushner
New member
- Local time
- Today, 12:48
- Joined
- Jun 23, 2015
- Messages
- 9
I have a database that had some code that enabled the user to click a button and it would take information from one Access query or table and paste it into specific locations in Excel. This is important because the last worksheet has specific formatting in place.
If it didn't, I'd just use the transfer spreadsheet option and not even bother opening Excel at all with code.
I've got it working well except for the last part. The last query being copied has eight records and only one is being sent to Excel. Same code as the other queries where all of their data is going to the right spot in Excel with the right number of records.
Any help would be appreciated.
Private Sub AM_Top_25_Click()
DoCmd.SetWarnings False
DoCmd.OpenQuery "delete_ShortPartItems", acNormal, acEdit
DoCmd.OpenQuery "append_to_Short_Part_Items", acNormal, acEdit
Dim Db As Database
Dim Rst As Recordset
Set Db = Nothing
Dim xlApp As Object
Dim strWhat As String, boolXL As Boolean
Dim objActiveWkb As Object
Dim fldCount As Integer
Dim recCount As Long
Dim iCol As Integer
Dim iRow As Integer
Dim recArray As Variant
Dim xlWb As Object
Dim xlWs As Object
Dim pCount As Integer
Dim pTest As String
boolXL = True
Set Db = CurrentDb
'Top 25 Query With Information from WIP Tab
Set Rst = Db.OpenRecordset("AftTop25_From_pcPsub_Details")
pCount = Rst.RecordCount
Set xlApp = CreateObject("excel.Application")
Set xlWb = xlApp.workbooks.Open("S:\PURCHASE\USERS\PCiufo\backup\Aftermarket_Top_25Template.xls ")
Set xlWs = xlWb.worksheets("Priority $")
xlApp.Visible = True
xlApp.UserControl = True
fldCount = Rst.Fields.Count
recArray = Rst.GetRows(pCount)
recCount = UBound(recArray, 2) + 1
'Dumps data into Rows and Columns
xlWs.cells(2, 1).Resize(recCount, fldCount).Value = TransposeDim(recArray)
Rst.Close
Set Rst = Db.OpenRecordset("Report_4 DocumnetDirect")
pCount = Rst.RecordCount
Set xlWs = xlWb.worksheets("Wip-PO")
xlApp.Visible = True
xlApp.UserControl = True
fldCount = Rst.Fields.Count
recArray = Rst.GetRows(pCount)
recCount = UBound(recArray, 2) + 1
xlWs.cells(2, 1).Resize(recCount, fldCount).Value = TransposeDim(recArray)
Rst.Close
Set Rst = Db.OpenRecordset("zqry03_UnitSummary_From_pcPsub")
pCount = Rst.RecordCount
Set xlWs = xlWb.worksheets("Summary")
xlApp.Visible = True
xlApp.UserControl = True
fldCount = Rst.Fields.Count
recArray = Rst.GetRows(pCount)
recCount = UBound(recArray, 2) + 1
xlWs.cells(5, 1).Resize(recCount, fldCount).Value = TransposeDim(recArray)
Rst.Close
Set Rst = Db.OpenRecordset("zqry02_MakePlannerSummary_From_pcPsub")
pCount = Rst.RecordCount
Set xlWs = xlWb.worksheets("Summary")
xlApp.Visible = True
xlApp.UserControl = True
fldCount = Rst.Fields.Count
recArray = Rst.GetRows(pCount)
recCount = UBound(recArray, 2) + 1
xlWs.cells(5, 4).Resize(recCount, fldCount).Value = TransposeDim(recArray)
Rst.Close
Set Rst = Db.OpenRecordset("zqry01_VendorSummary_From_pcPsub")
pCount = Rst.RecordCount
Set xlWs = xlWb.worksheets("Summary")
xlApp.Visible = True
xlApp.UserControl = True
fldCount = Rst.Fields.Count
recArray = Rst.GetRows(pCount)
recCount = UBound(recArray, 2) + 1
xlWs.cells(5, 8).Resize(recCount, fldCount).Value = TransposeDim(recArray)
Rst.Close
Set Rst = Nothing
DoCmd.SetWarnings True
End Sub
The function that it's calling TransposeDim is
Function TransposeDim(v As Variant) As Variant
Dim x As Long
Dim Y As Long
Dim Xupper As Long
Dim 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
If it didn't, I'd just use the transfer spreadsheet option and not even bother opening Excel at all with code.
I've got it working well except for the last part. The last query being copied has eight records and only one is being sent to Excel. Same code as the other queries where all of their data is going to the right spot in Excel with the right number of records.
Any help would be appreciated.
Private Sub AM_Top_25_Click()
DoCmd.SetWarnings False
DoCmd.OpenQuery "delete_ShortPartItems", acNormal, acEdit
DoCmd.OpenQuery "append_to_Short_Part_Items", acNormal, acEdit
Dim Db As Database
Dim Rst As Recordset
Set Db = Nothing
Dim xlApp As Object
Dim strWhat As String, boolXL As Boolean
Dim objActiveWkb As Object
Dim fldCount As Integer
Dim recCount As Long
Dim iCol As Integer
Dim iRow As Integer
Dim recArray As Variant
Dim xlWb As Object
Dim xlWs As Object
Dim pCount As Integer
Dim pTest As String
boolXL = True
Set Db = CurrentDb
'Top 25 Query With Information from WIP Tab
Set Rst = Db.OpenRecordset("AftTop25_From_pcPsub_Details")
pCount = Rst.RecordCount
Set xlApp = CreateObject("excel.Application")
Set xlWb = xlApp.workbooks.Open("S:\PURCHASE\USERS\PCiufo\backup\Aftermarket_Top_25Template.xls ")
Set xlWs = xlWb.worksheets("Priority $")
xlApp.Visible = True
xlApp.UserControl = True
fldCount = Rst.Fields.Count
recArray = Rst.GetRows(pCount)
recCount = UBound(recArray, 2) + 1
'Dumps data into Rows and Columns
xlWs.cells(2, 1).Resize(recCount, fldCount).Value = TransposeDim(recArray)
Rst.Close
Set Rst = Db.OpenRecordset("Report_4 DocumnetDirect")
pCount = Rst.RecordCount
Set xlWs = xlWb.worksheets("Wip-PO")
xlApp.Visible = True
xlApp.UserControl = True
fldCount = Rst.Fields.Count
recArray = Rst.GetRows(pCount)
recCount = UBound(recArray, 2) + 1
xlWs.cells(2, 1).Resize(recCount, fldCount).Value = TransposeDim(recArray)
Rst.Close
Set Rst = Db.OpenRecordset("zqry03_UnitSummary_From_pcPsub")
pCount = Rst.RecordCount
Set xlWs = xlWb.worksheets("Summary")
xlApp.Visible = True
xlApp.UserControl = True
fldCount = Rst.Fields.Count
recArray = Rst.GetRows(pCount)
recCount = UBound(recArray, 2) + 1
xlWs.cells(5, 1).Resize(recCount, fldCount).Value = TransposeDim(recArray)
Rst.Close
Set Rst = Db.OpenRecordset("zqry02_MakePlannerSummary_From_pcPsub")
pCount = Rst.RecordCount
Set xlWs = xlWb.worksheets("Summary")
xlApp.Visible = True
xlApp.UserControl = True
fldCount = Rst.Fields.Count
recArray = Rst.GetRows(pCount)
recCount = UBound(recArray, 2) + 1
xlWs.cells(5, 4).Resize(recCount, fldCount).Value = TransposeDim(recArray)
Rst.Close
Set Rst = Db.OpenRecordset("zqry01_VendorSummary_From_pcPsub")
pCount = Rst.RecordCount
Set xlWs = xlWb.worksheets("Summary")
xlApp.Visible = True
xlApp.UserControl = True
fldCount = Rst.Fields.Count
recArray = Rst.GetRows(pCount)
recCount = UBound(recArray, 2) + 1
xlWs.cells(5, 8).Resize(recCount, fldCount).Value = TransposeDim(recArray)
Rst.Close
Set Rst = Nothing
DoCmd.SetWarnings True
End Sub
The function that it's calling TransposeDim is
Function TransposeDim(v As Variant) As Variant
Dim x As Long
Dim Y As Long
Dim Xupper As Long
Dim 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