Good afternoon,
I am trying to figure out the best way to get data exported from Access into Excel. I have used the TransferSpreadhseet feature before to export entire tales or queries, but this is different.
Using VBA I need to be able to export various pieces of data into specific fields in an Excel spreadsheet. I have attached the destination spreadsheet, and the source data will come from more than one table. If you open the spreadsheet you will see cells in RED. These are fields that I need to fill in. The product section is partially pink, because there could be a variable number of products for each sheet.
So my question is, how do I export specific values into specific fields on a spreadsheet?
And to follow that up, I will actually need to make up to 7 copies of this spreadsheet in a single excel file, each containing a different list of products (based on unique grade level).
I would appreciate any advice you all can offer. Let's try to get the first question, then worry about the rest of it later.
Thanks!
Nate
Hi,
Here's a code that I use to export to various sheets in a Excel template file and then send the Excel file by e-mail.
It works fine, but I know that the code can be optimized....
Hope it helps
Cheers
Luís
Lisbon-Portugal
***********
Public Function ExportQuery() As String
On Error GoTo Err_Handler
Dim appExcel As Excel.Application
Dim wbk As Excel.Workbook
Dim wks As Excel.Worksheet
Dim sTemplate As String
Dim sOutput As String
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim sSQL As String
Dim IRecords As Long
Dim IRecords1 As Long
Dim IRecords2 As Long
Dim J As Long
Dim strPeriod As String
Dim strYear As String
Dim objOutlook As Object
Dim objOutlookMsg As Object
Dim objOutlookRecip As Object
Dim objOutlookAttach As Object
Dim strAppName As String
Dim MyAtt1
Dim MyAtt2
DoCmd.SetWarnings False
Set FS = CreateObject("Scripting.FileSystemObject")
strlocal = "G:\Opex_File"
strData = Format(Now(), "dd-mm-yyyy hhmmss")
DoCmd.Hourglass True
On Error Resume Next
timeini = Time
sTemplate = CurrentProject.path & "\OPEX Information Template.xls"
'sOutput = CurrentProject.path & "\OPEX Information " & strData & ".xls"
sOutput = strlocal & "\OPEX Information " & strData & ".xls"
If Dir(sOutput) <> "" Then Kill sOutput
FileCopy sTemplate, sOutput
Set appExcel = New Excel.Application
appExcel.Visible = True
Set wbk = appExcel.Workbooks.Open(sOutput)
' WARRANTS **************************
' Só envia os que não foram marcados como "enviados"
sSQL = "SELECT [Warrants].* " & _
"FROM [Warrants] " & _
"WHERE ((([Warrants].Enviado)=No));"
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
J = 3
Do Until rst.EOF
With wbk.Sheets("Warrants")
IRecords = IRecords + 1
'.Range("G3") = rst.Fields("Nome").Value
.Cells(J, 1).Value = rst.Fields("Nome").Value
.Cells(J, 2).Value = rst.Fields("Nome abreviado").Value
.Cells(J, 3).Value = rst.Fields("Tipo").Value
.Cells(J, 4).Value = rst.Fields("Activo subjacente").Value
.Cells(J, 5).Value = rst.Fields("Preço de Exercício").Value
.Cells(J, 6).Value = rst.Fields("Quantidade").Value
.Cells(J, 7).Value = rst.Fields("Data de Vencimento").Value
.Cells(J, 8).Value = rst.Fields("Preço de Emissão").Value
.Cells(J, 9).Value = rst.Fields("Paridade").Value
.Cells(J, 10).Value = rst.Fields("ISIN").Value
.Cells(J, 11).Value = rst.Fields("Código OPEX").Value
.Cells(J, 12).Value = rst.Fields("Código CVM").Value
.Cells(J, 13).Value = rst.Fields("Emitente").Value
.Cells(J, 14).Value = rst.Fields("Segmento").Value
.Cells(J, 15).Value = rst.Fields("UDN").Value
.Cells(J, 16).Value = rst.Fields("Data admissão").Value
.Cells(J, 17).Value = rst.Fields("Estilo").Value
.Cells(J, 18).Value = rst.Fields("Emissão").Value
.Cells(J, 19).Value = rst.Fields("Lote Mínimo").Value
.Cells(J, 20).Value = rst.Fields("Moeda").Value
End With
J = J + 1
rst.MoveNext
Loop
' TURBO-WARRANTS **************************
sSQL = "SELECT [Turbo-Warrants].* " & _
"FROM [Turbo-Warrants] " & _
"WHERE ((([Turbo-Warrants].Enviado)=No));"
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
J = 3
Do Until rst.EOF
With wbk.Sheets("Turbo-Warrants")
IRecords1 = IRecords1 + 1
'.Range("G3") = rst.Fields("Nome").Value
.Cells(J, 1).Value = rst.Fields("Nome").Value
.Cells(J, 2).Value = rst.Fields("Nome abreviado").Value
.Cells(J, 3).Value = rst.Fields("Tipo").Value
.Cells(J, 4).Value = rst.Fields("Activo subjacente").Value
.Cells(J, 5).Value = rst.Fields("Preço de Exercício").Value
.Cells(J, 6).Value = rst.Fields("Barreira").Value
.Cells(J, 7).Value = rst.Fields("Quantidade").Value
.Cells(J, 8).Value = rst.Fields("Data de Vencimento").Value
.Cells(J, 9).Value = rst.Fields("Preço de Emissão").Value
.Cells(J, 10).Value = rst.Fields("Paridade").Value
.Cells(J, 11).Value = rst.Fields("ISIN").Value
.Cells(J, 12).Value = rst.Fields("Código OPEX").Value
.Cells(J, 13).Value = rst.Fields("Código CVM").Value
.Cells(J, 14).Value = rst.Fields("Emitente").Value
.Cells(J, 15).Value = rst.Fields("Segmento").Value
.Cells(J, 16).Value = rst.Fields("UDN").Value
.Cells(J, 17).Value = rst.Fields("Data admissão").Value
.Cells(J, 18).Value = rst.Fields("Estilo").Value
.Cells(J, 19).Value = rst.Fields("Emissão").Value
.Cells(J, 20).Value = rst.Fields("Lote Mínimo").Value
.Cells(J, 21).Value = rst.Fields("Moeda").Value
.Cells(J, 22).Value = rst.Fields("Data de Exclusão").Value
End With
J = J + 1
rst.MoveNext
Loop
' Inline Warrants **************************
sSQL = "SELECT [Inline Warrants].* " & _
"FROM [Inline Warrants] " & _
"WHERE ((([Inline Warrants].Enviado)=No));"
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
J = 3
Do Until rst.EOF
With wbk.Sheets("Inline Warrants")
IRecords2 = IRecords2 + 1
'.Range("G3") = rst.Fields("Nome").Value
.Cells(J, 1).Value = rst.Fields("Nome").Value
.Cells(J, 2).Value = rst.Fields("Nome abreviado").Value
.Cells(J, 3).Value = rst.Fields("Activo subjacente").Value
.Cells(J, 4).Value = rst.Fields("Barreira inferior").Value
.Cells(J, 5).Value = rst.Fields("Barreira superior").Value
.Cells(J, 6).Value = rst.Fields("Quantidade").Value
.Cells(J, 7).Value = rst.Fields("Maturidade").Value
.Cells(J, 8).Value = rst.Fields("Preço").Value
.Cells(J, 9).Value = rst.Fields("Paridade").Value
.Cells(J, 10).Value = rst.Fields("ISIN").Value
.Cells(J, 11).Value = rst.Fields("Código OPEX").Value
.Cells(J, 12).Value = rst.Fields("Código CVM").Value
.Cells(J, 13).Value = rst.Fields("Emitente").Value
.Cells(J, 14).Value = rst.Fields("Segmento").Value
.Cells(J, 15).Value = rst.Fields("UDN").Value
.Cells(J, 16).Value = rst.Fields("Data admissão").Value
.Cells(J, 17).Value = rst.Fields("Estilo").Value
.Cells(J, 18).Value = rst.Fields("Emissão").Value
.Cells(J, 19).Value = rst.Fields("Lote Mínimo").Value
.Cells(J, 20).Value = rst.Fields("Moeda").Value
.Cells(J, 21).Value = rst.Fields("Data de Exclusão").Value
End With
J = J + 1
rst.MoveNext
Loop
wbk.Close True
appExcel.Quit
timefim = Time
Total = IRecords + IRecords1 + IRecords2
MsgBox "Foram processados: " & vbCrLf _
& " " & vbCrLf _
& " -> " & IRecords & " Warrants" & vbCrLf _
& " -> " & IRecords1 & " Turbo-Warrants" & vbCrLf _
& " -> " & IRecords2 & " Inline Warrants" & vbCrLf _
& " " & vbCrLf _
& " " & vbCrLf _
& "Total de " & Total & " registos" & vbCrLf _
& "processados em " + Format(timefim - timeini, "hh:nn:ss")
' Envia E-Mail
Call Shell(strAppName, 1)
strSubject = "Opex Information"
strEMailMsg = "Please find attached an updated file with Citi's and Commerzbank's warrants being negociated in Euronext." & Chr(10) & Chr(10) _
& "Best regards," & Chr(10) & Chr(10) _
& "*********" & Chr(10) _
& "*********" & Chr(10) _
& "*********" & Chr(10) _
& "*********" & Chr(10) _
& "*********" & Chr(10) _
& " " & Chr(10) _
& " " & Chr(10) _
& " " & Chr(10) _
& " " & Chr(10) _
& " "
MyAtt2 = sOutput
Const olMailItem As Long = 0
Const olFormatPlain As Long = 1
'Dim olApp As Object
'Dim objMail As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
.To = "youremail@mail.com; youremail@mail.com; youremail@mail.com"
.CC = "youremail@mail.com"
.Subject = strSubject
.Importance = 2
'.BodyFormat = olFormatPlain
.Body = strEMailMsg
.Attachments.Add (MyAtt2)
.Display
End With
DoCmd.OpenQuery "UPDT Opex information 1 enviado", acNormal, acEdit ' Marca "Yes" no enviado,
DoCmd.OpenQuery "UPDT Opex information 2 enviado", acNormal, acEdit ' caso a Data Exclusão não seja nula
DoCmd.OpenQuery "UPDT Opex information 3 enviado", acNormal, acEdit
DoCmd.SetWarnings True
Set wbk = Nothing
'appExcel.Quit
Set appExcel = Nothing
Set rst = Nothing
Set dbs = Nothing
DoCmd.Hourglass False
Err_Handler:
ExportQuery = Err.Description
'Resume exit_Here
End Function
Here's a code that I use to export to various sheets in a Excel template file and then send the Excel file by e-mail.
It works fine, but I know that the code can be optimized....
Hope it helps
Cheers
Luís
Lisbon-Portugal
***********
Public Function ExportQuery() As String
On Error GoTo Err_Handler
Dim appExcel As Excel.Application
Dim wbk As Excel.Workbook
Dim wks As Excel.Worksheet
Dim sTemplate As String
Dim sOutput As String
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim sSQL As String
Dim IRecords As Long
Dim IRecords1 As Long
Dim IRecords2 As Long
Dim J As Long
Dim strPeriod As String
Dim strYear As String
Dim objOutlook As Object
Dim objOutlookMsg As Object
Dim objOutlookRecip As Object
Dim objOutlookAttach As Object
Dim strAppName As String
Dim MyAtt1
Dim MyAtt2
DoCmd.SetWarnings False
Set FS = CreateObject("Scripting.FileSystemObject")
strlocal = "G:\Opex_File"
strData = Format(Now(), "dd-mm-yyyy hhmmss")
DoCmd.Hourglass True
On Error Resume Next
timeini = Time
sTemplate = CurrentProject.path & "\OPEX Information Template.xls"
'sOutput = CurrentProject.path & "\OPEX Information " & strData & ".xls"
sOutput = strlocal & "\OPEX Information " & strData & ".xls"
If Dir(sOutput) <> "" Then Kill sOutput
FileCopy sTemplate, sOutput
Set appExcel = New Excel.Application
appExcel.Visible = True
Set wbk = appExcel.Workbooks.Open(sOutput)
' WARRANTS **************************
' Só envia os que não foram marcados como "enviados"
sSQL = "SELECT [Warrants].* " & _
"FROM [Warrants] " & _
"WHERE ((([Warrants].Enviado)=No));"
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
J = 3
Do Until rst.EOF
With wbk.Sheets("Warrants")
IRecords = IRecords + 1
'.Range("G3") = rst.Fields("Nome").Value
.Cells(J, 1).Value = rst.Fields("Nome").Value
.Cells(J, 2).Value = rst.Fields("Nome abreviado").Value
.Cells(J, 3).Value = rst.Fields("Tipo").Value
.Cells(J, 4).Value = rst.Fields("Activo subjacente").Value
.Cells(J, 5).Value = rst.Fields("Preço de Exercício").Value
.Cells(J, 6).Value = rst.Fields("Quantidade").Value
.Cells(J, 7).Value = rst.Fields("Data de Vencimento").Value
.Cells(J, 8).Value = rst.Fields("Preço de Emissão").Value
.Cells(J, 9).Value = rst.Fields("Paridade").Value
.Cells(J, 10).Value = rst.Fields("ISIN").Value
.Cells(J, 11).Value = rst.Fields("Código OPEX").Value
.Cells(J, 12).Value = rst.Fields("Código CVM").Value
.Cells(J, 13).Value = rst.Fields("Emitente").Value
.Cells(J, 14).Value = rst.Fields("Segmento").Value
.Cells(J, 15).Value = rst.Fields("UDN").Value
.Cells(J, 16).Value = rst.Fields("Data admissão").Value
.Cells(J, 17).Value = rst.Fields("Estilo").Value
.Cells(J, 18).Value = rst.Fields("Emissão").Value
.Cells(J, 19).Value = rst.Fields("Lote Mínimo").Value
.Cells(J, 20).Value = rst.Fields("Moeda").Value
End With
J = J + 1
rst.MoveNext
Loop
' TURBO-WARRANTS **************************
sSQL = "SELECT [Turbo-Warrants].* " & _
"FROM [Turbo-Warrants] " & _
"WHERE ((([Turbo-Warrants].Enviado)=No));"
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
J = 3
Do Until rst.EOF
With wbk.Sheets("Turbo-Warrants")
IRecords1 = IRecords1 + 1
'.Range("G3") = rst.Fields("Nome").Value
.Cells(J, 1).Value = rst.Fields("Nome").Value
.Cells(J, 2).Value = rst.Fields("Nome abreviado").Value
.Cells(J, 3).Value = rst.Fields("Tipo").Value
.Cells(J, 4).Value = rst.Fields("Activo subjacente").Value
.Cells(J, 5).Value = rst.Fields("Preço de Exercício").Value
.Cells(J, 6).Value = rst.Fields("Barreira").Value
.Cells(J, 7).Value = rst.Fields("Quantidade").Value
.Cells(J, 8).Value = rst.Fields("Data de Vencimento").Value
.Cells(J, 9).Value = rst.Fields("Preço de Emissão").Value
.Cells(J, 10).Value = rst.Fields("Paridade").Value
.Cells(J, 11).Value = rst.Fields("ISIN").Value
.Cells(J, 12).Value = rst.Fields("Código OPEX").Value
.Cells(J, 13).Value = rst.Fields("Código CVM").Value
.Cells(J, 14).Value = rst.Fields("Emitente").Value
.Cells(J, 15).Value = rst.Fields("Segmento").Value
.Cells(J, 16).Value = rst.Fields("UDN").Value
.Cells(J, 17).Value = rst.Fields("Data admissão").Value
.Cells(J, 18).Value = rst.Fields("Estilo").Value
.Cells(J, 19).Value = rst.Fields("Emissão").Value
.Cells(J, 20).Value = rst.Fields("Lote Mínimo").Value
.Cells(J, 21).Value = rst.Fields("Moeda").Value
.Cells(J, 22).Value = rst.Fields("Data de Exclusão").Value
End With
J = J + 1
rst.MoveNext
Loop
' Inline Warrants **************************
sSQL = "SELECT [Inline Warrants].* " & _
"FROM [Inline Warrants] " & _
"WHERE ((([Inline Warrants].Enviado)=No));"
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
J = 3
Do Until rst.EOF
With wbk.Sheets("Inline Warrants")
IRecords2 = IRecords2 + 1
'.Range("G3") = rst.Fields("Nome").Value
.Cells(J, 1).Value = rst.Fields("Nome").Value
.Cells(J, 2).Value = rst.Fields("Nome abreviado").Value
.Cells(J, 3).Value = rst.Fields("Activo subjacente").Value
.Cells(J, 4).Value = rst.Fields("Barreira inferior").Value
.Cells(J, 5).Value = rst.Fields("Barreira superior").Value
.Cells(J, 6).Value = rst.Fields("Quantidade").Value
.Cells(J, 7).Value = rst.Fields("Maturidade").Value
.Cells(J, 8).Value = rst.Fields("Preço").Value
.Cells(J, 9).Value = rst.Fields("Paridade").Value
.Cells(J, 10).Value = rst.Fields("ISIN").Value
.Cells(J, 11).Value = rst.Fields("Código OPEX").Value
.Cells(J, 12).Value = rst.Fields("Código CVM").Value
.Cells(J, 13).Value = rst.Fields("Emitente").Value
.Cells(J, 14).Value = rst.Fields("Segmento").Value
.Cells(J, 15).Value = rst.Fields("UDN").Value
.Cells(J, 16).Value = rst.Fields("Data admissão").Value
.Cells(J, 17).Value = rst.Fields("Estilo").Value
.Cells(J, 18).Value = rst.Fields("Emissão").Value
.Cells(J, 19).Value = rst.Fields("Lote Mínimo").Value
.Cells(J, 20).Value = rst.Fields("Moeda").Value
.Cells(J, 21).Value = rst.Fields("Data de Exclusão").Value
End With
J = J + 1
rst.MoveNext
Loop
wbk.Close True
appExcel.Quit
timefim = Time
Total = IRecords + IRecords1 + IRecords2
MsgBox "Foram processados: " & vbCrLf _
& " " & vbCrLf _
& " -> " & IRecords & " Warrants" & vbCrLf _
& " -> " & IRecords1 & " Turbo-Warrants" & vbCrLf _
& " -> " & IRecords2 & " Inline Warrants" & vbCrLf _
& " " & vbCrLf _
& " " & vbCrLf _
& "Total de " & Total & " registos" & vbCrLf _
& "processados em " + Format(timefim - timeini, "hh:nn:ss")
' Envia E-Mail
Call Shell(strAppName, 1)
strSubject = "Opex Information"
strEMailMsg = "Please find attached an updated file with Citi's and Commerzbank's warrants being negociated in Euronext." & Chr(10) & Chr(10) _
& "Best regards," & Chr(10) & Chr(10) _
& "*********" & Chr(10) _
& "*********" & Chr(10) _
& "*********" & Chr(10) _
& "*********" & Chr(10) _
& "*********" & Chr(10) _
& " " & Chr(10) _
& " " & Chr(10) _
& " " & Chr(10) _
& " " & Chr(10) _
& " "
MyAtt2 = sOutput
Const olMailItem As Long = 0
Const olFormatPlain As Long = 1
'Dim olApp As Object
'Dim objMail As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
.To = "youremail@mail.com; youremail@mail.com; youremail@mail.com"
.CC = "youremail@mail.com"
.Subject = strSubject
.Importance = 2
'.BodyFormat = olFormatPlain
.Body = strEMailMsg
.Attachments.Add (MyAtt2)
.Display
End With
DoCmd.OpenQuery "UPDT Opex information 1 enviado", acNormal, acEdit ' Marca "Yes" no enviado,
DoCmd.OpenQuery "UPDT Opex information 2 enviado", acNormal, acEdit ' caso a Data Exclusão não seja nula
DoCmd.OpenQuery "UPDT Opex information 3 enviado", acNormal, acEdit
DoCmd.SetWarnings True
Set wbk = Nothing
'appExcel.Quit
Set appExcel = Nothing
Set rst = Nothing
Set dbs = Nothing
DoCmd.Hourglass False
Err_Handler:
ExportQuery = Err.Description
'Resume exit_Here
End Function
QUOTE (ICE929RR @ Mar 4 2010, 10:27 AM) 
Hi,
Here's a code that I use to export to various sheets in a Excel template file and then send the Excel file by e-mail.
It works fine, but I know that the code can be optimized....
Hope it helps
Cheers
Luís
Lisbon-Portugal
***********
Public Function ExportQuery() As String
On Error GoTo Err_Handler
Dim appExcel As Excel.Application
Dim wbk As Excel.Workbook
Dim wks As Excel.Worksheet
Dim sTemplate As String
Dim sOutput As String
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim sSQL As String
Dim IRecords As Long
Dim IRecords1 As Long
Dim IRecords2 As Long
Dim J As Long
Dim strPeriod As String
Dim strYear As String
Dim objOutlook As Object
Dim objOutlookMsg As Object
Dim objOutlookRecip As Object
Dim objOutlookAttach As Object
Dim strAppName As String
Dim MyAtt1
Dim MyAtt2
DoCmd.SetWarnings False
Set FS = CreateObject("Scripting.FileSystemObject")
strlocal = "G:\Opex_File"
strData = Format(Now(), "dd-mm-yyyy hhmmss")
DoCmd.Hourglass True
On Error Resume Next
timeini = Time
sTemplate = CurrentProject.path & "\OPEX Information Template.xls"
'sOutput = CurrentProject.path & "\OPEX Information " & strData & ".xls"
sOutput = strlocal & "\OPEX Information " & strData & ".xls"
If Dir(sOutput) <> "" Then Kill sOutput
FileCopy sTemplate, sOutput
Set appExcel = New Excel.Application
appExcel.Visible = True
Set wbk = appExcel.Workbooks.Open(sOutput)
' WARRANTS **************************
' Só envia os que não foram marcados como "enviados"
sSQL = "SELECT [Warrants].* " & _
"FROM [Warrants] " & _
"WHERE ((([Warrants].Enviado)=No));"
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
J = 3
Do Until rst.EOF
With wbk.Sheets("Warrants")
IRecords = IRecords + 1
'.Range("G3") = rst.Fields("Nome").Value
.Cells(J, 1).Value = rst.Fields("Nome").Value
.Cells(J, 2).Value = rst.Fields("Nome abreviado").Value
.Cells(J, 3).Value = rst.Fields("Tipo").Value
.Cells(J, 4).Value = rst.Fields("Activo subjacente").Value
.Cells(J, 5).Value = rst.Fields("Preço de Exercício").Value
.Cells(J, 6).Value = rst.Fields("Quantidade").Value
.Cells(J, 7).Value = rst.Fields("Data de Vencimento").Value
.Cells(J, 8).Value = rst.Fields("Preço de Emissão").Value
.Cells(J, 9).Value = rst.Fields("Paridade").Value
.Cells(J, 10).Value = rst.Fields("ISIN").Value
.Cells(J, 11).Value = rst.Fields("Código OPEX").Value
.Cells(J, 12).Value = rst.Fields("Código CVM").Value
.Cells(J, 13).Value = rst.Fields("Emitente").Value
.Cells(J, 14).Value = rst.Fields("Segmento").Value
.Cells(J, 15).Value = rst.Fields("UDN").Value
.Cells(J, 16).Value = rst.Fields("Data admissão").Value
.Cells(J, 17).Value = rst.Fields("Estilo").Value
.Cells(J, 18).Value = rst.Fields("Emissão").Value
.Cells(J, 19).Value = rst.Fields("Lote Mínimo").Value
.Cells(J, 20).Value = rst.Fields("Moeda").Value
End With
J = J + 1
rst.MoveNext
Loop
' TURBO-WARRANTS **************************
sSQL = "SELECT [Turbo-Warrants].* " & _
"FROM [Turbo-Warrants] " & _
"WHERE ((([Turbo-Warrants].Enviado)=No));"
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
J = 3
Do Until rst.EOF
With wbk.Sheets("Turbo-Warrants")
IRecords1 = IRecords1 + 1
'.Range("G3") = rst.Fields("Nome").Value
.Cells(J, 1).Value = rst.Fields("Nome").Value
.Cells(J, 2).Value = rst.Fields("Nome abreviado").Value
.Cells(J, 3).Value = rst.Fields("Tipo").Value
.Cells(J, 4).Value = rst.Fields("Activo subjacente").Value
.Cells(J, 5).Value = rst.Fields("Preço de Exercício").Value
.Cells(J, 6).Value = rst.Fields("Barreira").Value
.Cells(J, 7).Value = rst.Fields("Quantidade").Value
.Cells(J, 8).Value = rst.Fields("Data de Vencimento").Value
.Cells(J, 9).Value = rst.Fields("Preço de Emissão").Value
.Cells(J, 10).Value = rst.Fields("Paridade").Value
.Cells(J, 11).Value = rst.Fields("ISIN").Value
.Cells(J, 12).Value = rst.Fields("Código OPEX").Value
.Cells(J, 13).Value = rst.Fields("Código CVM").Value
.Cells(J, 14).Value = rst.Fields("Emitente").Value
.Cells(J, 15).Value = rst.Fields("Segmento").Value
.Cells(J, 16).Value = rst.Fields("UDN").Value
.Cells(J, 17).Value = rst.Fields("Data admissão").Value
.Cells(J, 18).Value = rst.Fields("Estilo").Value
.Cells(J, 19).Value = rst.Fields("Emissão").Value
.Cells(J, 20).Value = rst.Fields("Lote Mínimo").Value
.Cells(J, 21).Value = rst.Fields("Moeda").Value
.Cells(J, 22).Value = rst.Fields("Data de Exclusão").Value
End With
J = J + 1
rst.MoveNext
Loop
' Inline Warrants **************************
sSQL = "SELECT [Inline Warrants].* " & _
"FROM [Inline Warrants] " & _
"WHERE ((([Inline Warrants].Enviado)=No));"
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
J = 3
Do Until rst.EOF
With wbk.Sheets("Inline Warrants")
IRecords2 = IRecords2 + 1
'.Range("G3") = rst.Fields("Nome").Value
.Cells(J, 1).Value = rst.Fields("Nome").Value
.Cells(J, 2).Value = rst.Fields("Nome abreviado").Value
.Cells(J, 3).Value = rst.Fields("Activo subjacente").Value
.Cells(J, 4).Value = rst.Fields("Barreira inferior").Value
.Cells(J, 5).Value = rst.Fields("Barreira superior").Value
.Cells(J, 6).Value = rst.Fields("Quantidade").Value
.Cells(J, 7).Value = rst.Fields("Maturidade").Value
.Cells(J, 8).Value = rst.Fields("Preço").Value
.Cells(J, 9).Value = rst.Fields("Paridade").Value
.Cells(J, 10).Value = rst.Fields("ISIN").Value
.Cells(J, 11).Value = rst.Fields("Código OPEX").Value
.Cells(J, 12).Value = rst.Fields("Código CVM").Value
.Cells(J, 13).Value = rst.Fields("Emitente").Value
.Cells(J, 14).Value = rst.Fields("Segmento").Value
.Cells(J, 15).Value = rst.Fields("UDN").Value
.Cells(J, 16).Value = rst.Fields("Data admissão").Value
.Cells(J, 17).Value = rst.Fields("Estilo").Value
.Cells(J, 18).Value = rst.Fields("Emissão").Value
.Cells(J, 19).Value = rst.Fields("Lote Mínimo").Value
.Cells(J, 20).Value = rst.Fields("Moeda").Value
.Cells(J, 21).Value = rst.Fields("Data de Exclusão").Value
End With
J = J + 1
rst.MoveNext
Loop
wbk.Close True
appExcel.Quit
timefim = Time
Total = IRecords + IRecords1 + IRecords2
MsgBox "Foram processados: " & vbCrLf _
& " " & vbCrLf _
& " -> " & IRecords & " Warrants" & vbCrLf _
& " -> " & IRecords1 & " Turbo-Warrants" & vbCrLf _
& " -> " & IRecords2 & " Inline Warrants" & vbCrLf _
& " " & vbCrLf _
& " " & vbCrLf _
& "Total de " & Total & " registos" & vbCrLf _
& "processados em " + Format(timefim - timeini, "hh:nn:ss")
' Envia E-Mail
Call Shell(strAppName, 1)
strSubject = "Opex Information"
strEMailMsg = "Please find attached an updated file with Citi's and Commerzbank's warrants being negociated in Euronext." & Chr(10) & Chr(10) _
& "Best regards," & Chr(10) & Chr(10) _
& "*********" & Chr(10) _
& "*********" & Chr(10) _
& "*********" & Chr(10) _
& "*********" & Chr(10) _
& "*********" & Chr(10) _
& " " & Chr(10) _
& " " & Chr(10) _
& " " & Chr(10) _
& " " & Chr(10) _
& " "
MyAtt2 = sOutput
Const olMailItem As Long = 0
Const olFormatPlain As Long = 1
'Dim olApp As Object
'Dim objMail As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
.To = "youremail@mail.com; youremail@mail.com; youremail@mail.com"
.CC = "youremail@mail.com"
.Subject = strSubject
.Importance = 2
'.BodyFormat = olFormatPlain
.Body = strEMailMsg
.Attachments.Add (MyAtt2)
.Display
End With
DoCmd.OpenQuery "UPDT Opex information 1 enviado", acNormal, acEdit ' Marca "Yes" no enviado,
DoCmd.OpenQuery "UPDT Opex information 2 enviado", acNormal, acEdit ' caso a Data Exclusão não seja nula
DoCmd.OpenQuery "UPDT Opex information 3 enviado", acNormal, acEdit
DoCmd.SetWarnings True
Set wbk = Nothing
'appExcel.Quit
Set appExcel = Nothing
Set rst = Nothing
Set dbs = Nothing
DoCmd.Hourglass False
Err_Handler:
ExportQuery = Err.Description
'Resume exit_Here
End Function
Here's a code that I use to export to various sheets in a Excel template file and then send the Excel file by e-mail.
It works fine, but I know that the code can be optimized....
Hope it helps
Cheers
Luís
Lisbon-Portugal
***********
Public Function ExportQuery() As String
On Error GoTo Err_Handler
Dim appExcel As Excel.Application
Dim wbk As Excel.Workbook
Dim wks As Excel.Worksheet
Dim sTemplate As String
Dim sOutput As String
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim sSQL As String
Dim IRecords As Long
Dim IRecords1 As Long
Dim IRecords2 As Long
Dim J As Long
Dim strPeriod As String
Dim strYear As String
Dim objOutlook As Object
Dim objOutlookMsg As Object
Dim objOutlookRecip As Object
Dim objOutlookAttach As Object
Dim strAppName As String
Dim MyAtt1
Dim MyAtt2
DoCmd.SetWarnings False
Set FS = CreateObject("Scripting.FileSystemObject")
strlocal = "G:\Opex_File"
strData = Format(Now(), "dd-mm-yyyy hhmmss")
DoCmd.Hourglass True
On Error Resume Next
timeini = Time
sTemplate = CurrentProject.path & "\OPEX Information Template.xls"
'sOutput = CurrentProject.path & "\OPEX Information " & strData & ".xls"
sOutput = strlocal & "\OPEX Information " & strData & ".xls"
If Dir(sOutput) <> "" Then Kill sOutput
FileCopy sTemplate, sOutput
Set appExcel = New Excel.Application
appExcel.Visible = True
Set wbk = appExcel.Workbooks.Open(sOutput)
' WARRANTS **************************
' Só envia os que não foram marcados como "enviados"
sSQL = "SELECT [Warrants].* " & _
"FROM [Warrants] " & _
"WHERE ((([Warrants].Enviado)=No));"
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
J = 3
Do Until rst.EOF
With wbk.Sheets("Warrants")
IRecords = IRecords + 1
'.Range("G3") = rst.Fields("Nome").Value
.Cells(J, 1).Value = rst.Fields("Nome").Value
.Cells(J, 2).Value = rst.Fields("Nome abreviado").Value
.Cells(J, 3).Value = rst.Fields("Tipo").Value
.Cells(J, 4).Value = rst.Fields("Activo subjacente").Value
.Cells(J, 5).Value = rst.Fields("Preço de Exercício").Value
.Cells(J, 6).Value = rst.Fields("Quantidade").Value
.Cells(J, 7).Value = rst.Fields("Data de Vencimento").Value
.Cells(J, 8).Value = rst.Fields("Preço de Emissão").Value
.Cells(J, 9).Value = rst.Fields("Paridade").Value
.Cells(J, 10).Value = rst.Fields("ISIN").Value
.Cells(J, 11).Value = rst.Fields("Código OPEX").Value
.Cells(J, 12).Value = rst.Fields("Código CVM").Value
.Cells(J, 13).Value = rst.Fields("Emitente").Value
.Cells(J, 14).Value = rst.Fields("Segmento").Value
.Cells(J, 15).Value = rst.Fields("UDN").Value
.Cells(J, 16).Value = rst.Fields("Data admissão").Value
.Cells(J, 17).Value = rst.Fields("Estilo").Value
.Cells(J, 18).Value = rst.Fields("Emissão").Value
.Cells(J, 19).Value = rst.Fields("Lote Mínimo").Value
.Cells(J, 20).Value = rst.Fields("Moeda").Value
End With
J = J + 1
rst.MoveNext
Loop
' TURBO-WARRANTS **************************
sSQL = "SELECT [Turbo-Warrants].* " & _
"FROM [Turbo-Warrants] " & _
"WHERE ((([Turbo-Warrants].Enviado)=No));"
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
J = 3
Do Until rst.EOF
With wbk.Sheets("Turbo-Warrants")
IRecords1 = IRecords1 + 1
'.Range("G3") = rst.Fields("Nome").Value
.Cells(J, 1).Value = rst.Fields("Nome").Value
.Cells(J, 2).Value = rst.Fields("Nome abreviado").Value
.Cells(J, 3).Value = rst.Fields("Tipo").Value
.Cells(J, 4).Value = rst.Fields("Activo subjacente").Value
.Cells(J, 5).Value = rst.Fields("Preço de Exercício").Value
.Cells(J, 6).Value = rst.Fields("Barreira").Value
.Cells(J, 7).Value = rst.Fields("Quantidade").Value
.Cells(J, 8).Value = rst.Fields("Data de Vencimento").Value
.Cells(J, 9).Value = rst.Fields("Preço de Emissão").Value
.Cells(J, 10).Value = rst.Fields("Paridade").Value
.Cells(J, 11).Value = rst.Fields("ISIN").Value
.Cells(J, 12).Value = rst.Fields("Código OPEX").Value
.Cells(J, 13).Value = rst.Fields("Código CVM").Value
.Cells(J, 14).Value = rst.Fields("Emitente").Value
.Cells(J, 15).Value = rst.Fields("Segmento").Value
.Cells(J, 16).Value = rst.Fields("UDN").Value
.Cells(J, 17).Value = rst.Fields("Data admissão").Value
.Cells(J, 18).Value = rst.Fields("Estilo").Value
.Cells(J, 19).Value = rst.Fields("Emissão").Value
.Cells(J, 20).Value = rst.Fields("Lote Mínimo").Value
.Cells(J, 21).Value = rst.Fields("Moeda").Value
.Cells(J, 22).Value = rst.Fields("Data de Exclusão").Value
End With
J = J + 1
rst.MoveNext
Loop
' Inline Warrants **************************
sSQL = "SELECT [Inline Warrants].* " & _
"FROM [Inline Warrants] " & _
"WHERE ((([Inline Warrants].Enviado)=No));"
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
J = 3
Do Until rst.EOF
With wbk.Sheets("Inline Warrants")
IRecords2 = IRecords2 + 1
'.Range("G3") = rst.Fields("Nome").Value
.Cells(J, 1).Value = rst.Fields("Nome").Value
.Cells(J, 2).Value = rst.Fields("Nome abreviado").Value
.Cells(J, 3).Value = rst.Fields("Activo subjacente").Value
.Cells(J, 4).Value = rst.Fields("Barreira inferior").Value
.Cells(J, 5).Value = rst.Fields("Barreira superior").Value
.Cells(J, 6).Value = rst.Fields("Quantidade").Value
.Cells(J, 7).Value = rst.Fields("Maturidade").Value
.Cells(J, 8).Value = rst.Fields("Preço").Value
.Cells(J, 9).Value = rst.Fields("Paridade").Value
.Cells(J, 10).Value = rst.Fields("ISIN").Value
.Cells(J, 11).Value = rst.Fields("Código OPEX").Value
.Cells(J, 12).Value = rst.Fields("Código CVM").Value
.Cells(J, 13).Value = rst.Fields("Emitente").Value
.Cells(J, 14).Value = rst.Fields("Segmento").Value
.Cells(J, 15).Value = rst.Fields("UDN").Value
.Cells(J, 16).Value = rst.Fields("Data admissão").Value
.Cells(J, 17).Value = rst.Fields("Estilo").Value
.Cells(J, 18).Value = rst.Fields("Emissão").Value
.Cells(J, 19).Value = rst.Fields("Lote Mínimo").Value
.Cells(J, 20).Value = rst.Fields("Moeda").Value
.Cells(J, 21).Value = rst.Fields("Data de Exclusão").Value
End With
J = J + 1
rst.MoveNext
Loop
wbk.Close True
appExcel.Quit
timefim = Time
Total = IRecords + IRecords1 + IRecords2
MsgBox "Foram processados: " & vbCrLf _
& " " & vbCrLf _
& " -> " & IRecords & " Warrants" & vbCrLf _
& " -> " & IRecords1 & " Turbo-Warrants" & vbCrLf _
& " -> " & IRecords2 & " Inline Warrants" & vbCrLf _
& " " & vbCrLf _
& " " & vbCrLf _
& "Total de " & Total & " registos" & vbCrLf _
& "processados em " + Format(timefim - timeini, "hh:nn:ss")
' Envia E-Mail
Call Shell(strAppName, 1)
strSubject = "Opex Information"
strEMailMsg = "Please find attached an updated file with Citi's and Commerzbank's warrants being negociated in Euronext." & Chr(10) & Chr(10) _
& "Best regards," & Chr(10) & Chr(10) _
& "*********" & Chr(10) _
& "*********" & Chr(10) _
& "*********" & Chr(10) _
& "*********" & Chr(10) _
& "*********" & Chr(10) _
& " " & Chr(10) _
& " " & Chr(10) _
& " " & Chr(10) _
& " " & Chr(10) _
& " "
MyAtt2 = sOutput
Const olMailItem As Long = 0
Const olFormatPlain As Long = 1
'Dim olApp As Object
'Dim objMail As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
.To = "youremail@mail.com; youremail@mail.com; youremail@mail.com"
.CC = "youremail@mail.com"
.Subject = strSubject
.Importance = 2
'.BodyFormat = olFormatPlain
.Body = strEMailMsg
.Attachments.Add (MyAtt2)
.Display
End With
DoCmd.OpenQuery "UPDT Opex information 1 enviado", acNormal, acEdit ' Marca "Yes" no enviado,
DoCmd.OpenQuery "UPDT Opex information 2 enviado", acNormal, acEdit ' caso a Data Exclusão não seja nula
DoCmd.OpenQuery "UPDT Opex information 3 enviado", acNormal, acEdit
DoCmd.SetWarnings True
Set wbk = Nothing
'appExcel.Quit
Set appExcel = Nothing
Set rst = Nothing
Set dbs = Nothing
DoCmd.Hourglass False
Err_Handler:
ExportQuery = Err.Description
'Resume exit_Here
End Function
Thanks Luis! I think this will be very helpful. Particularly the part about assigning specific values to specific cells. I have not played with that type of code in Access before, so thank you for the push in the right direction!
Just curious, does this code create a copy of an existing Excel Spreadsheet and update the sheets inside? Or does it create a new blank workbook and sheets? From your code it appears that you are using a copy of a template file, which is perfect for me.
Thanks again!
Nate
QUOTE (nschoonover @ Mar 4 2010, 01:26 PM)
Just curious, does this code create a copy of an existing Excel Spreadsheet and update the sheets inside? Or does it create a new blank workbook and sheets? From your code it appears that you are using a copy of a template file, which is perfect for me.
Hi Nate,
Yes
By using an Excel template, you can save the file with another name, so in doing this you never damage the original file (template)
Cheers,
Luís
Lisbon - Portugal
QUOTE (ICE929RR @ Mar 5 2010, 09:03 AM)
Hi Nate,
Yes
By using an Excel template, you can save the file with another name, so in doing this you never damage the original file (template)
Cheers,
Luís
Lisbon - Portugal
Yes
By using an Excel template, you can save the file with another name, so in doing this you never damage the original file (template)
Cheers,
Luís
Lisbon - Portugal
Thanks Luís! This was very helpful. I have a followup question.
Is there a way to take the original template file, and make several copies of it as separate tabs in the new file? Each tab will have the same format but different data. Each tab will also have a unique name. I figure out how to rename the tab using this:
CODE
wks.Name = "Gr" & Me.Combo30.value
'This replaces the template tab name with a specific name based on "Gr" and the grade value from the combo box.
'This replaces the template tab name with a specific name based on "Gr" and the grade value from the combo box.
But I am not sure how to insert a new tab in the same file. I will keep playing, but if you have any ides, please let me know!
thanks,
Nate
PS: I just posted the entire section of code that I am using including your implementation.
CODE
Private Sub Command32_Click()
On Error GoTo Err_Handler
'export the data to Excel
'First setup the variables to start an Excel Application, Workbook, and Sheet
Dim appExcel As Object
Dim wbk As Object
Dim wks As Object
Dim TemplateLoc As String
Dim OutputLoc As String
Dim LocalLoc As String
Dim FileNamePostfix As String
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim SQLText As String
Dim OtherProductInfo As String
Dim Row As Integer
DoCmd.Hourglass True
'Reference the original template as the source, and copy it to the desktop with a new filename.
'replace this with a folder location chooser dialog box
LocalLoc = "C:\Documents and Settings\nschoonover\Desktop"
FileNamePostfix = Me.Combo28.value & "_" & Format(Now(), "dd-mm-yyyy")
'location of the tempalte file (move this to the network eventually)
TemplateLoc = CurrentProject.Path & "\Product List Template.xls"
'location for the destination file
OutputLoc = LocalLoc & "\Product List Template_" & FileNamePostfix & ".xls"
'I think this delete previous versions with the same name (overwrite?)
If Dir(OutputLoc) <> "" Then Kill OutputLoc
'copy the file to a new filename (this preserves the original template)
FileCopy TemplateLoc, OutputLoc
Set appExcel = CreateObject("Excel.Application")
'appExcel.Visible = True
Set wbk = appExcel.workbooks.Open(OutputLoc)
Set wks = wbk.Sheets("ProductList")
'define the recordset(s) that will give the data required for the Excel Sheet
Dim rstContract As Recordset
Dim rstProductList As Recordset
Dim db As Database
Set db = CurrentDb()
'add an easy method for user to identify which product lists to create (by contract and grade)
'for now... just defualt to contract and grade selected in the filter combo boxes *****(there is no error checking for this yet..)
Set rstContract = db.OpenRecordset("SELECT tbl.ContractID, tbl.ShipLocation, tbl.PersonReceiving, tbl.ShippingLevel, tbl.ShipDate, tbl.PackStartDate, tbl.PackEndDate, tbl.ShipMethod, tbl.ReturnADs FROM dbo_tblContractInformation AS tbl WHERE (((tbl.ContractID)='" & Me.Combo28.value & "'));", dbOpenDynaset, dbSeeChanges)
Set rstProductList = db.OpenRecordset("SELECT Prod.ContractCode, Prod.GradeMasterID, Prod.RealProductName, Prod.FixedAtContract, Prod.FixedAtGrade, Ratio.RealProductName, Prod.CP1s, Prod.CP5s, Prod.CP6s, Prod.CP10s, Prod.CP20s, Prod.OveragePercent, Prod.RoundTo, Prod.DisplayStatus, Prod.DisplayMakeupStatus, Prod.Returnable, Prod.Secure FROM tblProductList AS Prod LEFT JOIN tblProductList AS Ratio ON Prod.RatioToProductID = Ratio.ProductID WHERE (((Prod.ContractCode)='" & Me.Combo28.value & "') AND ((Prod.GradeMasterID)='" & Me.Combo30.value & "')) ORDER BY Prod.RealProductName;", dbOpenDynaset, dbSeeChanges)
rstProductList.MoveLast
rstProductList.MoveFirst
'define the recordset for the workbook/sheet
'export the data to specific fields
With wks
.Name = "Gr" & Me.Combo30.value
.Range("C3").value = rstContract.Fields("ContractID").value
.Range("C4").value = rstContract.Fields("ShipLocation").value
.Range("C5").value = rstContract.Fields("PersonReceiving").value
.Range("C6").value = rstContract.Fields("ShippingLevel").value
.Range("U3").value = rstContract.Fields("ShipDate").value
.Range("U4").value = rstContract.Fields("PackStartDate").value & " to " & rstContract.Fields("PackEndDate").value
.Range("U5").value = rstContract.Fields("ShipMethod").value
If rstContract.Fields("ReturnADs").value = "TRUE" Then .Range("U6").value = "Yes" Else .Range("U6").value = "No"
.Range("K3").value = Str(rstProductList.Fields("GradeMasterID").value)
'loop export each product
Row = 1 'offset from row 11, increment this for each new row of data.
While Not rstProductList.EOF
'simple info
.Range("A10").offset(Row, 0).value = rstProductList.Fields("Prod.RealProductName").value
.Range("T10").offset(Row, 0).value = rstProductList.Fields("DisplayStatus").value
.Range("U10").offset(Row, 0).value = rstProductList.Fields("DisplayMakeupStatus").value
If rstProductList.Fields("Returnable").value = "TRUE" Then .Range("V10").offset(Row, 0).value = "Yes" Else .Range("V10").offset(Row, 0).value = "No"
If rstProductList.Fields("Secure").value = "TRUE" Then .Range("W10").offset(Row, 0).value = "Yes" Else .Range("W10").offset(Row, 0).value = "No"
'advanced formatting info
OtherProductInfo = ""
If (rstProductList.Fields("FixedAtGrade").value = True) Then OtherProductInfo = OtherProductInfo & "Imported, "
If (rstProductList.Fields("FixedAtContract").value > 0) Then OtherProductInfo = OtherProductInfo & "Fixed At Contract " & rstProductList.Fields("FixedAtContract").value & ", "
If (Nz(rstProductList.Fields("Ratio.RealProductName").value, "") <> "") Then OtherProductInfo = OtherProductInfo & "Ratio 1:1 to " & rstProductList.Fields("Ratio.RealProductName").value & ", "
If (rstProductList.Fields("CP1s").value = True) Or (rstProductList.Fields("CP5s").value = True) Or (rstProductList.Fields("CP6s").value = True) Or (rstProductList.Fields("CP10s").value = True) Or (rstProductList.Fields("CP20s").value = True) Then
OtherProductInfo = OtherProductInfo & "Classpacks of "
If (rstProductList.Fields("CP1s").value = True) Then OtherProductInfo = OtherProductInfo & "1, "
If (rstProductList.Fields("CP5s").value = True) Then OtherProductInfo = OtherProductInfo & "5, "
If (rstProductList.Fields("CP6s").value = True) Then OtherProductInfo = OtherProductInfo & "6, "
If (rstProductList.Fields("CP10s").value = True) Then OtherProductInfo = OtherProductInfo & "10, "
If (rstProductList.Fields("CP20s").value = True) Then OtherProductInfo = OtherProductInfo & "20, "
End If
If (rstProductList.Fields("OveragePercent").value > 0) Then OtherProductInfo = OtherProductInfo & rstProductList.Fields("OveragePercent").value & "% Overage, "
If (rstProductList.Fields("RoundTo").value > 0) Then OtherProductInfo = OtherProductInfo & " Rount to " & rstProductList.Fields("RoundTo").value & ", "
If Right(OtherProductInfo, 2) = ", " Then OtherProductInfo = Left(OtherProductInfo, Len(OtherProductInfo) - 2)
.Range("O10").offset(Row, 0).value = OtherProductInfo
Row = Row + 1
rstProductList.MoveNext
Wend
End With
'close files and recordsets
wbk.Close True
appExcel.Quit
Set rstProductList = Nothing
Set rstContract = Nothing
Set db = Nothing
DoCmd.Hourglass False
MsgBox "Product List Export Completed Successfully!!! :) ", vbInformation, "Export Completed Successfully!"
GoTo SkipErr
Err_Handler:
DoCmd.Hourglass False
MsgBox "Failed with Error code: " & Err.Number & vbCrLf & vbCrLf & Err.Description
SkipErr:
End Sub
On Error GoTo Err_Handler
'export the data to Excel
'First setup the variables to start an Excel Application, Workbook, and Sheet
Dim appExcel As Object
Dim wbk As Object
Dim wks As Object
Dim TemplateLoc As String
Dim OutputLoc As String
Dim LocalLoc As String
Dim FileNamePostfix As String
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim SQLText As String
Dim OtherProductInfo As String
Dim Row As Integer
DoCmd.Hourglass True
'Reference the original template as the source, and copy it to the desktop with a new filename.
'replace this with a folder location chooser dialog box
LocalLoc = "C:\Documents and Settings\nschoonover\Desktop"
FileNamePostfix = Me.Combo28.value & "_" & Format(Now(), "dd-mm-yyyy")
'location of the tempalte file (move this to the network eventually)
TemplateLoc = CurrentProject.Path & "\Product List Template.xls"
'location for the destination file
OutputLoc = LocalLoc & "\Product List Template_" & FileNamePostfix & ".xls"
'I think this delete previous versions with the same name (overwrite?)
If Dir(OutputLoc) <> "" Then Kill OutputLoc
'copy the file to a new filename (this preserves the original template)
FileCopy TemplateLoc, OutputLoc
Set appExcel = CreateObject("Excel.Application")
'appExcel.Visible = True
Set wbk = appExcel.workbooks.Open(OutputLoc)
Set wks = wbk.Sheets("ProductList")
'define the recordset(s) that will give the data required for the Excel Sheet
Dim rstContract As Recordset
Dim rstProductList As Recordset
Dim db As Database
Set db = CurrentDb()
'add an easy method for user to identify which product lists to create (by contract and grade)
'for now... just defualt to contract and grade selected in the filter combo boxes *****(there is no error checking for this yet..)
Set rstContract = db.OpenRecordset("SELECT tbl.ContractID, tbl.ShipLocation, tbl.PersonReceiving, tbl.ShippingLevel, tbl.ShipDate, tbl.PackStartDate, tbl.PackEndDate, tbl.ShipMethod, tbl.ReturnADs FROM dbo_tblContractInformation AS tbl WHERE (((tbl.ContractID)='" & Me.Combo28.value & "'));", dbOpenDynaset, dbSeeChanges)
Set rstProductList = db.OpenRecordset("SELECT Prod.ContractCode, Prod.GradeMasterID, Prod.RealProductName, Prod.FixedAtContract, Prod.FixedAtGrade, Ratio.RealProductName, Prod.CP1s, Prod.CP5s, Prod.CP6s, Prod.CP10s, Prod.CP20s, Prod.OveragePercent, Prod.RoundTo, Prod.DisplayStatus, Prod.DisplayMakeupStatus, Prod.Returnable, Prod.Secure FROM tblProductList AS Prod LEFT JOIN tblProductList AS Ratio ON Prod.RatioToProductID = Ratio.ProductID WHERE (((Prod.ContractCode)='" & Me.Combo28.value & "') AND ((Prod.GradeMasterID)='" & Me.Combo30.value & "')) ORDER BY Prod.RealProductName;", dbOpenDynaset, dbSeeChanges)
rstProductList.MoveLast
rstProductList.MoveFirst
'define the recordset for the workbook/sheet
'export the data to specific fields
With wks
.Name = "Gr" & Me.Combo30.value
.Range("C3").value = rstContract.Fields("ContractID").value
.Range("C4").value = rstContract.Fields("ShipLocation").value
.Range("C5").value = rstContract.Fields("PersonReceiving").value
.Range("C6").value = rstContract.Fields("ShippingLevel").value
.Range("U3").value = rstContract.Fields("ShipDate").value
.Range("U4").value = rstContract.Fields("PackStartDate").value & " to " & rstContract.Fields("PackEndDate").value
.Range("U5").value = rstContract.Fields("ShipMethod").value
If rstContract.Fields("ReturnADs").value = "TRUE" Then .Range("U6").value = "Yes" Else .Range("U6").value = "No"
.Range("K3").value = Str(rstProductList.Fields("GradeMasterID").value)
'loop export each product
Row = 1 'offset from row 11, increment this for each new row of data.
While Not rstProductList.EOF
'simple info
.Range("A10").offset(Row, 0).value = rstProductList.Fields("Prod.RealProductName").value
.Range("T10").offset(Row, 0).value = rstProductList.Fields("DisplayStatus").value
.Range("U10").offset(Row, 0).value = rstProductList.Fields("DisplayMakeupStatus").value
If rstProductList.Fields("Returnable").value = "TRUE" Then .Range("V10").offset(Row, 0).value = "Yes" Else .Range("V10").offset(Row, 0).value = "No"
If rstProductList.Fields("Secure").value = "TRUE" Then .Range("W10").offset(Row, 0).value = "Yes" Else .Range("W10").offset(Row, 0).value = "No"
'advanced formatting info
OtherProductInfo = ""
If (rstProductList.Fields("FixedAtGrade").value = True) Then OtherProductInfo = OtherProductInfo & "Imported, "
If (rstProductList.Fields("FixedAtContract").value > 0) Then OtherProductInfo = OtherProductInfo & "Fixed At Contract " & rstProductList.Fields("FixedAtContract").value & ", "
If (Nz(rstProductList.Fields("Ratio.RealProductName").value, "") <> "") Then OtherProductInfo = OtherProductInfo & "Ratio 1:1 to " & rstProductList.Fields("Ratio.RealProductName").value & ", "
If (rstProductList.Fields("CP1s").value = True) Or (rstProductList.Fields("CP5s").value = True) Or (rstProductList.Fields("CP6s").value = True) Or (rstProductList.Fields("CP10s").value = True) Or (rstProductList.Fields("CP20s").value = True) Then
OtherProductInfo = OtherProductInfo & "Classpacks of "
If (rstProductList.Fields("CP1s").value = True) Then OtherProductInfo = OtherProductInfo & "1, "
If (rstProductList.Fields("CP5s").value = True) Then OtherProductInfo = OtherProductInfo & "5, "
If (rstProductList.Fields("CP6s").value = True) Then OtherProductInfo = OtherProductInfo & "6, "
If (rstProductList.Fields("CP10s").value = True) Then OtherProductInfo = OtherProductInfo & "10, "
If (rstProductList.Fields("CP20s").value = True) Then OtherProductInfo = OtherProductInfo & "20, "
End If
If (rstProductList.Fields("OveragePercent").value > 0) Then OtherProductInfo = OtherProductInfo & rstProductList.Fields("OveragePercent").value & "% Overage, "
If (rstProductList.Fields("RoundTo").value > 0) Then OtherProductInfo = OtherProductInfo & " Rount to " & rstProductList.Fields("RoundTo").value & ", "
If Right(OtherProductInfo, 2) = ", " Then OtherProductInfo = Left(OtherProductInfo, Len(OtherProductInfo) - 2)
.Range("O10").offset(Row, 0).value = OtherProductInfo
Row = Row + 1
rstProductList.MoveNext
Wend
End With
'close files and recordsets
wbk.Close True
appExcel.Quit
Set rstProductList = Nothing
Set rstContract = Nothing
Set db = Nothing
DoCmd.Hourglass False
MsgBox "Product List Export Completed Successfully!!! :) ", vbInformation, "Export Completed Successfully!"
GoTo SkipErr
Err_Handler:
DoCmd.Hourglass False
MsgBox "Failed with Error code: " & Err.Number & vbCrLf & vbCrLf & Err.Description
SkipErr:
End Sub
Ok...
I have 3 tbls
Warrants
Turbo-Warrants
Inline Warrants
and in the template, I have 3 sheets named "Warrants", "Turbo-Warrants" and "Inline Warrants" (without the quotes)
For the tbl Warrants I have to select it, so...
sSQL = "SELECT [Warrants].* " & _
"FROM [Warrants] " & _
"WHERE ((([Warrants].Enviado)=No));"
then the output goes to Sheet Warrants
Do Until rst.EOF
With wbk.Sheets("Warrants")
IRecords = IRecords + 1
The template has to have the sheets created
Repeat this for all the sheets that you want
Try it
Cheers
Luís
I have 3 tbls
Warrants
Turbo-Warrants
Inline Warrants
and in the template, I have 3 sheets named "Warrants", "Turbo-Warrants" and "Inline Warrants" (without the quotes)
For the tbl Warrants I have to select it, so...
sSQL = "SELECT [Warrants].* " & _
"FROM [Warrants] " & _
"WHERE ((([Warrants].Enviado)=No));"
then the output goes to Sheet Warrants
Do Until rst.EOF
With wbk.Sheets("Warrants")
IRecords = IRecords + 1
The template has to have the sheets created
Repeat this for all the sheets that you want
Try it
Cheers
Luís
QUOTE (ICE929RR @ Mar 10 2010, 11:02 AM)
Ok...
I have 3 tbls
Warrants
Turbo-Warrants
Inline Warrants
and in the template, I have 3 sheets named "Warrants", "Turbo-Warrants" and "Inline Warrants" (without the quotes)
For the tbl Warrants I have to select it, so...
sSQL = "SELECT [Warrants].* " & _
"FROM [Warrants] " & _
"WHERE ((([Warrants].Enviado)=No));"
then the output goes to Sheet Warrants
Do Until rst.EOF
With wbk.Sheets("Warrants")
IRecords = IRecords + 1
The template has to have the sheets created
Repeat this for all the sheets that you want
Try it
Cheers
Luís
I have 3 tbls
Warrants
Turbo-Warrants
Inline Warrants
and in the template, I have 3 sheets named "Warrants", "Turbo-Warrants" and "Inline Warrants" (without the quotes)
For the tbl Warrants I have to select it, so...
sSQL = "SELECT [Warrants].* " & _
"FROM [Warrants] " & _
"WHERE ((([Warrants].Enviado)=No));"
then the output goes to Sheet Warrants
Do Until rst.EOF
With wbk.Sheets("Warrants")
IRecords = IRecords + 1
The template has to have the sheets created
Repeat this for all the sheets that you want
Try it
Cheers
Luís
Thanks I didn't think of creating the sheets ahead of time. Thanks for all your help Luís!!
QUOTE (nschoonover @ Mar 10 2010, 01:32 PM)
Thanks I didn't think of creating the sheets ahead of time. Thanks for all your help Luís!!
Hey
Glad I could help.
Cheers
Luís
This is a "lo-fi" version of our main content. To view the full version with more information, formatting and images, please click here.