# 5 Re: Excel programming - 1004 Select method.....
Below is code that I use, to create a spreadsheet, and transfer the contents of database table into Excel, using the results from one of the sheets, I also create a graph.
Hopefully this will point you in the right direction, but if you've any questions come back to me.
JP
Private Sub mnuUtilties_Export_Statistics_Click()
Dim objExcelA As Excel.Application
Dim objExcelW As Excel.Workbook
Dim objExcelSI As Excel.Worksheet 'Issues Work Sheet
Dim objExcelSS As Excel.Worksheet 'Stirs Work Sheet
Dim objExcelCI As Excel.Chart
Dim cho As Excel.ChartObject
Dim ch As Excel.Chart
'Dim objExcelCI As Excel.Charts
Dim objExcelCS As Excel.ChartObject
Dim adrQry As ADODB.Recordset
Dim adrChgType As ADODB.Recordset
Dim Row As Long
Dim chgtype As Long
Dim LastCell As String
Dim statYear As String
Dim bkmark As Variant
On Error GoTo mnuUtilties_Export_Statistics_Click_Error
With dlgFileLocation
.DefaultExt = ".XLS"
.DialogTitle = "Where is the Spread Sheet"
.filter = "Excel SpreadSheet|*.XLS|All Files|*.*"
.FilterIndex = 1
.FileName = "Issue Statistics"
.CancelError = True
.Flags = FileOpenConstants.cdlOFNHideReadOnly + FileOpenConstants.cdlOFNCreatePrompt + FileOpenConstants.cdlOFNOverwritePrompt
.InitDir = "C:\TEMP\"
.ShowSave
End With
Me.MousePointer = vbHourglass
statYear = InputBox("Do you want the stats for any particular year? (0 implies all years)", "Stats for a year", 0)
If statYear = "" Then 'User probably pressed CANCEL
Exit Sub
End If
Set objExcelA = New Excel.Application
Set objExcelW = objExcelA.Workbooks.add
Set adrQry = New ADODB.Recordset
With adrQry
If statYear = "0" Then
.Source = "Statistics Order By ChangeType, StatsDate"
Else
.Source = "Statistics where Left$(statsdate, 4) = " & _
Chr$(39) & statYear & Chr$(39) & _
" Order By ChangeType, StatsDate"
End If
.CursorLocation = adUseClient
.CursorType = adOpenDynamic
.LockType = adLockReadOnly
.ActiveConnection = adoConnection
.Open , , , , adCmdTable
End With
Set adrChgType = New ADODB.Recordset
With adrChgType
.Source = "ChangeTypes"
.CursorLocation = adUseClient
.CursorType = adOpenDynamic
.LockType = adLockReadOnly
.ActiveConnection = adoConnection
.Open , , , , adCmdTableDirect
bkmark = .bookmark
End With
Do While Not adrQry.EOF
If chgtype <> adrQry.Fields("ChangeType") Then
adrChgType.Find "ChangeTypeId = " & adrQry.Fields("ChangeType"), , adSearchForward, bkmark
Set objExcelSI = objExcelW.Worksheets.add
objExcelSI.Name = adrChgType.Fields("ChangeType") & " - Issues"
chgtype = adrQry.Fields("ChangeType")
Set objExcelSS = objExcelW.Worksheets.add
objExcelSS.Name = adrChgType.Fields("ChangeType") & " - Stirs"
objExcelSI.Cells(1, 1).Value = "Year / Week"
objExcelSI.Cells(1, 2).Value = "Curent Outstanding"
objExcelSI.Cells(1, 3) = "New Issues This Week"
objExcelSI.Cells(1, 4) = "Completed Issues This Week"
objExcelSS.Cells(1, 1).Value = "Year / Week"
objExcelSS.Cells(1, 2).Value = "Outstanding Stirs"
objExcelSS.Cells(1, 3).Value = "New Stirs This Week"
objExcelSS.Cells(1, 4) = "Completed Stirs This Week"
Row = 2
objExcelW.Charts.add
Set objExcelCI = objExcelW.ActiveChart
objExcelCI.Activate
objExcelCI.Name = adrChgType.Fields("ChangeType") & " - Issues Chart"
'objExcelW.Charts.add
'Set objExcelCS = objExcelW.Charts(1)
'Set objExcelCS = objExcelW.ActiveChart
'objExcelCS.Activate
'objExcelCS.Name = adrChgType.Fields("ChangeType") & " - Stirs Chart"
'objExcelCS.ChartType = xl3DLine
'objExcelCI.ChartTitle = adrChgType.Fields("Chart ChangeType") & " - Issues"
End If
objExcelSI.Cells(Row, 1).Value = adrQry.Fields("StatsDate")
objExcelSI.Cells(Row, 2).Value = adrQry.Fields("Curent Outstanding")
objExcelSI.Cells(Row, 3) = adrQry.Fields("New Issues This Week")
objExcelSI.Cells(Row, 4) = adrQry.Fields("Completed Issues This Week")
objExcelSS.Cells(Row, 1).Value = adrQry.Fields("StatsDate")
objExcelSS.Cells(Row, 2).Value = adrQry.Fields("Outstanding Stirs This Week")
adrQry.MoveNext
If adrQry.EOF Then
LastCell = "D" & Mid$(Str$(Row), 2)
objExcelCI.SetSourceData objExcelSI.Range("a1:" & LastCell), xlColumns
objExcelCI.ChartType = xlLineMarkers
objExcelCI.Legend.Position = xlLegendPositionBottom
objExcelCI.HasTitle = True
objExcelCI.ChartTitle.Text = objExcelCI.Name
Else
If chgtype <> adrQry.Fields("ChangeType") Then
LastCell = "D" & Mid$(Str$(Row), 2)
objExcelCI.SetSourceData objExcelSI.Range("a1:" & LastCell), xlColumns
objExcelCI.ChartType = xlLineMarkers
objExcelCI.Legend.Position = xlLegendPositionBottom
objExcelCI.HasTitle = True
objExcelCI.ChartTitle.Text = objExcelCI.Name
End If
End If
Row = Row + 1
Loop
objExcelA.DisplayAlerts = False
objExcelW.SaveAs dlgFileLocation.FileName
objExcelA.Quit
Set objExcelA = Nothing
Set objExcelW = Nothing
Set objExcelSI = Nothing
Set objExcelSS = Nothing
Set objExcelCI = Nothing
Set objExcelCS = Nothing
If adrQry.State = adStateOpen Then
adrQry.Close
End If
If adrChgType.State = adStateOpen Then
adrChgType.Close
End If
Set adrQry = Nothing
Set adrChgType = Nothing
Me.MousePointer = vbNormal
Exit Sub
mnuUtilties_Export_Statistics_Click_Error:
Me.MousePointer = vbNormal
If Err = 32755 Then
Set objExcelA = Nothing
Set objExcelW = Nothing
Set objExcelSI = Nothing
Set objExcelSS = Nothing
Set objExcelCI = Nothing
Set objExcelCS = Nothing
Set adrQry = Nothing
Exit Sub
End If
Call ErrorMessage(Me.Caption & " - Export Statistics")
objExcelW.Close False
objExcelA.Quit
Set objExcelA = Nothing
Set objExcelW = Nothing
Set objExcelSI = Nothing
Set objExcelSS = Nothing
Set objExcelCI = Nothing
Set objExcelCS = Nothing
If adrQry.State = adStateOpen Then
adrQry.Close
End If
Set adrQry = Nothing
Exit Sub
End Sub
