Hi there
Many thanks to those people who contributed to this group, helped me
greatly.
Enclose, my code, hope it helps others :-
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
'***AIM-Testing String
'call Export_Excel_9("","","","SUPPLIER DOCUMENT SCHEDULE","SUBMISSION
DATE","","","",#16-10-2003#,#18-03-2003#,"A3")
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 = ""
strPath_Security_WkGrp = ""
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 = ""
Set cnt = New ADODB.Connection
With cnt
.Provider = "Microsoft.Jet.OLEDB.4.0"
.CursorLocation = adUseClient
.Properties("Jet OLEDB:Database Password") = ""
.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
strSQL1 = ""
ElseIf TriggerX = "A4" Then
strSQL1 = ""
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-(P,1)
With x1.range("P1:P1")
.Select
.Value = tbx2
.Font.Size = 10
.Font.Bold = True
End With
'***AIM-(P,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
End If
Exit_Export_Excel_9:
Exit Function
Err_Export_Excel_9:
msgbox ERR.Description
Resume Exit_Export_Excel_9
End Function
