Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Knowledge gained from Access to Excel VBA Automation User request
Hope this helps other..
Apprciate help of others within this group... Areas : - ADO, Excel VBA formatting Public Function Export_Excel_9(tbx1 As Variant, tbx2 As Variant, tbx3 As Variant, tbx4 As Variant, tbx5 As Variant, tbx6 As Variant, tbx7 As Variant, tbx8 As Variant, tbx9 As Variant, tbx10 As Variant, TriggerX As Variant) 'On Error GoTo Err_Export_Excel_9 Dim X1 As Excel.Application, excel_app As Object, excel_sheet As Object, row As Long, w As Object, s As Object, excel_workgroup As Workbook Dim statement As String, I As Integer, strDB As String Dim cnt As New ADODB.Connection, rst As New ADODB.Recordset Dim strPath_Security_WkGrp As String, strPath_Security_User As String Dim strPath_Security_Pwd As String, strPath As String Dim strSQL1 As String, strSQL2 As String, strSQL3 As String, strSQL4 As String Dim wbkNew As Excel.Workbook Dim a1 As String, b1 As String, c1 As String, d1 As String, e1 As String, f1 As String, g1 As String, h1 As String, i1 As String, j1 As String, k1 As String, l1 As String, m1 As String, n1 As String, o1 As String, p1 As String, q1 As String, borders As String, range As String strPath = "..........\Staff.mdb" strPath_Security_WkGrp = "C:\WWL.Expediting_VBA.NEW\WorkGroup\wwl_sys1. mda" strPath_Security_User = "" strPath_Security_Pwd = "" '***AIM-Open the Excel spreadsheet. Set X1 = CreateObject("Excel.application") X1.Workbooks.Add '***AIM-Display Excel and give user control of Excel X1.Visible = True X1.UserControl = True '***AIM-Check for later versions. If Val(X1.Application.Version) = 8 Then Set excel_sheet = X1.ActiveSheet Else Set excel_sheet = X1 End If '***AIM-Set the string to the path of the Working database strDB = "........Staff.mdb" Set cnt = New ADODB.Connection With cnt .Provider = "Microsoft.Jet.OLEDB.4.0" .CursorLocation = adUseClient .Properties("Jet OLEDB:Database Password") = "techCentral" .Properties("Jet OLEDB:System Database") = strPath_Security_WkGrp .Open strPath, strPath_Security_User, strPath_Security_Pwd End With '***AIM-Query- See qry_Excel_VBA_Automation_A3_29-01-2004 If TriggerX = "A3" Then strSQL4= "" ElseIf TriggerX = "A4" Then strSQL4 = "" End If GoTo err_start err_start: Set rst = New ADODB.Recordset rst.Open strSQL4, cnt '***AIM-Make the column headers. For I = 1 To rst.Fields.Count - 1 excel_sheet.Cells(9, I).Value = rst.Fields(I).NAME Next I '***AIM-Get data from the database and insert '***AIM-it into the spreadsheet. row = 10 Do While Not rst.EOF For I = 1 To rst.Fields.Count - 1 excel_sheet.Cells(row, I) = rst.Fields(I).Value Next I row = row + 1 rst.MoveNext Loop '***AIM-Close the database. rst.Close Set rst = Nothing cnt.Close Set cnt = Nothing If TriggerX = "A3" Then '***AIM-Make the header... excel_sheet.Rows(9).Font.Bold = True 'excel_sheet.Rows(9).WrapText = True excel_sheet.Rows(9).HorizontalAlignment = xlCenter '***AIM-Make the columns autofit the data. excel_sheet.range(excel_sheet.Cells(1, 1), _ excel_sheet.Cells(1, row)).Select X1.Selection.EntireColumn.AutoFit excel_sheet.range(excel_sheet.Cells(3, 1), _ excel_sheet.Cells(6, row)).Select X1.Selection.EntireColumn.AutoFit excel_sheet.range(excel_sheet.Cells(8, 1), _ excel_sheet.Cells(18, row)).Select X1.Selection.EntireColumn.AutoFit 'X1.Selection.Columns.AutoFit '***AIM-Print Setup properties X1.ActiveSheet.PageSetup.CenterHeader = tbx4 X1.ActiveSheet.PageSetup.RightHeader = tbx2 & Chr(10) & Format(Date, "dd-mm-yyyy") X1.ActiveSheet.PageSetup.Zoom = 50 X1.ActiveSheet.PageSetup.Orientation = xlLandscape X1.ActiveSheet.PageSetup.PrintArea = "$A$1:" & "$Q" & "$" & row X1.ActiveSheet.PageSetup.PaperSize = xlPaperA3 '***AIM-Formating of Spreadsheet '***AIM-Active Sheet X1.ActiveWindow.Zoom = 70 '***AIM-Top Half '***AIM-(B,1) With X1.range("B1:B1") .Select .Value = tbx1 .Font.Size = 12 .Font.Bold = True End With '***AIM-(B,3) With X1.range("B3:B3") .Select .Value = tbx4 & " " & tbx5 .Font.Size = 12 .Font.Bold = True End With '***AIM-(B,5) With X1.range("B5:B5") .Select .Value = tbx6 & " " & tbx7 & " Vendor : " & tbx8 .Font.Size = 12 .Font.Bold = True End With '***AIM-(B,7) With X1.range("B7:B7") .Select .Value = " Forecast Despatch Date : " & tbx10 & " Placed Order Date : " & tbx9 .Font.Size = 10 .Font.Bold = True End With '***AIM-(Q,1) With X1.range("P1:P1") .Select .Value = tbx2 .Font.Size = 10 .Font.Bold = True End With '***AIM-(Q,2) With X1.range("P2:P2") .Select .Value = tbx3 .Font.Size = 10 .Font.Bold = True End With '--------------------------------------------- '***AIM-Bottom Half '***AIM-(A,1)-PDRL Code a1 = "A10:" & "A" & row With X1.range(a1) .Select '.ShrinkToFit = True '.WrapText = True .HorizontalAlignment = xlCenter .Font.Size = 10 '.Font.Bold = True End With '***AIM-(B,1)-PDRL Description b1 = "B10:" & "B" & row With X1.range(b1) .Select .RowHeight = 40 .ColumnWidth = 50 .WrapText = True .ShrinkToFit = True .HorizontalAlignment = xlLeft .Font.Size = 10 '.Font.Bold = True '.Height = 15.55 End With '***AIM-(C,1)-Vendor Doc Number c1 = "C10:" & "C" & row With X1.range(c1) .Select '.ShrinkToFit = True '.WrapText = True .HorizontalAlignment = xlLeft .Font.Size = 10 '.Font.Bold = True End With '***AIM-(D,1)-Vendor Doc Rev d1 = "D10:" & "D" & row With X1.range(d1) .Select '.ShrinkToFit = True '.WrapText = True .HorizontalAlignment = xlCenter .Font.Size = 10 '.Font.Bold = True End With '***AIM-(E,1)-Client Doc No e1 = "E10:" & "E" & row With X1.range(e1) .Select '.ShrinkToFit = True '.WrapText = True .HorizontalAlignment = xlLeft .Font.Size = 10 '.Font.Bold = True End With '***AIM-(F,1)-Client Doc Rev f1 = "F10:" & "F" & row With X1.range(f1) .Select '.ShrinkToFit = True '.WrapText = True .HorizontalAlignment = xlCenter .Font.Size = 10 '.Font.Bold = True End With '***AIM-(G,1)-Vendor Doc Title g1 = "G10:" & "G" & row With X1.range(g1) .Select .RowHeight = 40 .ColumnWidth = 50 .WrapText = True .ShrinkToFit = True .HorizontalAlignment = xlLeft .Font.Size = 10 '.Font.Bold = True '.Height = 15.55 End With '***AIM-(H,1)-PDRL Agreed Date h1 = "H10:" & "H" & row With X1.range(h1) .Select '.ShrinkToFit = True '.WrapText = True .HorizontalAlignment = xlCenter .Font.Size = 10 '.Font.Bold = True End With '***AIM-(I,1)-Vendor Forecast Date i1 = "I10:" & "I" & row With X1.range(i1) .Select '.ShrinkToFit = True '.WrapText = True .HorizontalAlignment = xlCenter .Font.Size = 10 '.Font.Bold = True End With '***AIM-(J,1)-No of Paper Copies j1 = "J10:" & "J" & row With X1.range(j1) .Select '.ShrinkToFit = True '.WrapText = True .HorizontalAlignment = xlCenter .Font.Size = 10 '.Font.Bold = True End With '***AIM-(K,1)-Copied Required Electronic Format k1 = "K10:" & "K" & row With X1.range(k1) .Select '.ShrinkToFit = True '.WrapText = True .HorizontalAlignment = xlCenter .Font.Size = 10 '.Font.Bold = True End With '***AIM-(L,1)-Key Doc l1 = "L10:" & "L" & row With X1.range(l1) .Select '.ShrinkToFit = True '.WrapText = True .HorizontalAlignment = xlCenter .Font.Size = 10 '.Font.Bold = True End With '***AIM-(M,1)-Status m1 = "M10:" & "M" & row With X1.range(m1) .Select '.ShrinkToFit = True '.WrapText = True .HorizontalAlignment = xlCenter .Font.Size = 10 '.Font.Bold = True End With '***AIM-(N,1)-Method n1 = "N10:" & "N" & row With X1.range(n1) .Select '.ShrinkToFit = True '.WrapText = True .HorizontalAlignment = xlCenter .Font.Size = 10 '.Font.Bold = True End With '***AIM-(O,1)-Duration o1 = "O10:" & "O" & row With X1.range(o1) .Select '.ShrinkToFit = True '.WrapText = True .HorizontalAlignment = xlCenter .Font.Size = 10 '.Font.Bold = True End With '***AIM-(P,1)-Reconcilation p1 = "P10:" & "P" & row With X1.range(p1) .Select .RowHeight = 40 .ColumnWidth = 30 .WrapText = True .ShrinkToFit = True .HorizontalAlignment = xlLeft .Font.Size = 10 '.Font.Bold = True '.Height = 15.55 End With '***AIM-(Q,1)-Supplier Comment q1 = "Q10:" & "Q" & row With X1.range(q1) .Select '.ShrinkToFit = True '.WrapText = True .HorizontalAlignment = xlLeft .Font.Size = 10 '.Font.Bold = True End With '--------------------------------------------- '***AIM-Border borders = "A9:" & "Q" & row With X1.range(borders) .borders(xlDiagonalDown).LineStyle = xlNone .borders(xlDiagonalUp).LineStyle = xlNone With .borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With .borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With .borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With .borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With .borders(xlInsideVertical) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With .borders(xlInsideHorizontal) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With End With '***AIM-Freeze the header row so it doesn't scroll -- e.g. Freeze !!! 'excel_sheet.Rows(1).Select 'X1.ActiveWindow.FreezePanes = True ' Select the first cell. excel_sheet.Cells(1, 1).Select '***AIM-Comment the Close and Quit lines to keep '***AIM-Excel running so you can see it. '***AIM-Close the workbook saving changes. 'x1.ActiveWorkbook.Close True 'x1.Quit Set excel_sheet = Nothing Set X1 = Nothing 'Screen.MousePointer = vbDefault msgbox "Transfered over - " & Format$(row - 10) & " PDRL Line items.", vbInformation 'cnt.Close 'Set rst = Nothing 'Set cnt = Nothing ElseIf TriggerX = "A4" Then 'dido End If Exit_Export_Excel_9: Exit Function Err_Export_Excel_9: msgbox ERR.Description Resume Exit_Export_Excel_9 End Function |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Access to Excel using SQL.REQUEST | Excel Discussion (Misc queries) | |||
automation from access into excel | Excel Discussion (Misc queries) | |||
Access Automation to Excel | Excel Programming | |||
Access automation from Excel | Excel Programming | |||
Automation Excel & Access | Excel Programming |