Private Sub cmdExport_Click()
' Note:
' You must have a reference to the Excel Object Library.
'
Dim i As Long
Dim j As Long
Dim lRowCount As Long
Dim lPasteCount As Long
Dim sLtr As String
Dim sStart As String
Dim sEnd As String
Dim sRowData As String
Dim sSelData As String
Dim oExcelApp As excel.Application
Dim oWs As excel.Worksheet
Dim oWb As excel.Workbook
Const cNUMCOLS = 6
Const cNUMROWS = 700
Const cFIXEDROWS = 6
Const cCLIPROWS = 500
On Error GoTo ErrorHandler
Screen.MousePointer = vbHourglass
If Dir(sNewXlsFile) <> "" Then Kill sNewXlsFile
'
' Create an invisible Excel instance.
'
' Open a previously created worksheet that has most
' of the desired formatting already. Save this template
' as a new file so as not to destroy it.
'
Set oExcelApp = CreateObject("EXCEL.APPLICATION")
oExcelApp.Visible = False
oExcelApp.Workbooks.Open FileName:=sXlsTemplate, ReadOnly:=True, ignoreReadOnlyRecommended:=True
Set oWs = oExcelApp.ActiveSheet
Set oWb = oExcelApp.ActiveWorkbook
oWs.SaveAs FileName:=sNewXlsFile, FileFormat:=xlNormal
'
' Populate the header information by writting
' directly to specific cells.
'
' Note:
' Strings are prefixed with a quote mark.
'
With oWs
.Cells(1, 4).Value = "'Value1"
.Cells(2, 4).Value = "'Value2"
.Cells(3, 4).Value = "'Value3"
.Cells(4, 4).Value = "'Value4 Value4 Value4 Value4 Value4 Value4"
.Cells(5, 5).Value = "'Value5"
.Cells(5, 6).Value = "'Value6"
.Cells(5, 7).Value = "'Value7"
End With
'
' Now lets populate the "body" of the spreadsheet.
' Determine the range of cells to be populated
' and change their format to numeric.
'
sStart = "A" & CStr(cFIXEDROWS + 1)
sLtr = Mid$("ABCDEFGHIJKLMNOPQRSTUVWXYZ", cNUMCOLS + 1, 1)
sEnd = sLtr & CStr(cFIXEDROWS + cNUMROWS + 1)
oWs.Range(sStart, sEnd).Select
oWs.Range(sStart, sEnd).Activate
oWs.Range(sStart, sEnd).NumberFormat = "#,##0.00"
'
' Populate the body of the spreadsheet.
'
sSelData = ""
lRowCount = 0
lPasteCount = 0
For i = 0 To cNUMROWS
sRowData = ""
'
' Create the rows to send to Excel. Each row
' is a tab delimited string of values terminated
' by a carriage return and line feed. Data can
' come from a grid or other source.
'
For j = 0 To cNUMCOLS
sRowData = sRowData & CStr(j) & vbTab
Next
sRowData = Left$(sRowData, Len(sRowData) - 1)
'
' Rows are accumulated into blocks then stored in
' the clipboard and pasted into Excel in one shot.
'
' They can be written one at a time but this is
' faster since the data is kept in memory and
' there are fewer calls to Excel.
'
sSelData = sSelData + sRowData + vbCrLf
lRowCount = lRowCount + 1
If lRowCount = cCLIPROWS Then
Clipboard.Clear
Clipboard.SetText sSelData
sSelData = ""
With oWs
.Range("A" & CStr(lPasteCount * cCLIPROWS + cFIXEDROWS)).Select
.Paste
.Range("A1").Select
End With
lRowCount = 0
lPasteCount = lPasteCount + 1
End If
Next
'
' Paste the last block of data into the worksheet.
'
Clipboard.Clear
Clipboard.SetText sSelData
With oWs
.Range("A" & CStr(lPasteCount * cCLIPROWS + cFIXEDROWS)).Select
.Paste
.Range("A1").Select
End With
'
' Change the formatting on a few cells.
'
' Select and highlight a cell. Change the font
' style and color on certain parts of its contents.
'
oWs.Range("D4").Select
oWs.Range("D4").Activate
With oExcelApp.ActiveCell.Characters(Start:=1, Length:=10).Font
.FontStyle = "Regular"
.Size = 11
.ColorIndex = 5
End With
With oExcelApp.ActiveCell.Characters(Start:=20, Length:=30).Font
.FontStyle = "Italic"
.Size = 11
.ColorIndex = xlAutomatic
End With
'
' Just for fun, change the color of
' the first column to Red.
'
sStart = "A" & CStr(cFIXEDROWS + 1)
sEnd = "A" & CStr(cFIXEDROWS + cNUMROWS + 1)
oWs.Range(sStart, sEnd).Select
oWs.Range(sStart, sEnd).Activate
oWs.Range(sStart, sEnd).Font.ColorIndex = 3
'
' Change the border and color of the last row.
'
j = (lPasteCount * cCLIPROWS) + cFIXEDROWS + lRowCount
For i = 1 To cNUMCOLS + 1
With oWs.Cells(j, i)
.Borders(xlTop).LineStyle = xlDouble
.Font.Bold = True
.Font.ColorIndex = 3
End With
Next
'
' Make the last row a total line. Build and insert
' a formula into its first cell. Then copy the
' formula to the remaining cells. When it is copied
' Excel will update the cell references for you.
'
oWs.Cells(j, 1).Value = "=SUM(A" & CStr(cFIXEDROWS + 1) & ":A" & CStr(j - 1) & ")"
For i = 1 To cNUMCOLS
oWs.Cells(j, 1).Copy
oWs.Cells(j, i + 1).Select
oWs.Paste
Next
'
' Save the changed worksheet.
'
oWb.Save
oWb.Saved = True
'
' Terminate and release the Excel objects.
'
oExcelApp.Quit
Set oWs = Nothing
Set oWb = Nothing
Set oExcelApp = Nothing
Screen.MousePointer = vbDefault
MsgBox "Data export complete", vbInformation, "Excel Export Example"
Exit Sub
ErrorHandler:
Screen.MousePointer = vbDefault
MsgBox Err.Description & " (" & CStr(Err.Number) & ")", vbExclamation, "Excel Export Example"
On Error Resume Next
oExcelApp.Quit
Set oWs = Nothing
Set oWb = Nothing
Set oExcelApp = Nothing
End Sub
