Private Sub test001()
'just to test the procedure below
MakeReporIntExcel "D:\Temp\"
End Sub
Public Sub MakeReporIntExcel(sExportFolder$)
'
Dim objExcelApp As Object
Dim WrkBk As Object, rngActive As Object, rngInput As Object
Dim objActiveSheet As Object ' ...
Dim iListNo% 'List NO
Dim iRowNo%
Dim sBaseQueryName As String
Dim v As Variant, s$, sTemp$, sUsluga$, sUslugaName$
Dim i%, x%
'
'--------------------------------------------------------------------------
On Error GoTo MakeReporIntExcel_Err
DoCmd.Hourglass True '
MakeReporIntExcel_StartNewList:
If iListNo = 0 Then
iListNo = 1
Set objExcelApp = CreateObject("Excel.Application")
'objExcelApp.Visible = True
'Create new WorkBook
Set WrkBk = objExcelApp.WorkBooks.Add
End If
'Link to active List
Set objActiveSheet = WrkBk.Sheets(iListNo)
'Name List
objActiveSheet.Name = "My list Name " & iListNo
'First string
'Link to sell А2 and set focus to it.
Set rngActive = objActiveSheet.Cells(1, 2) 'First string - second column
rngActive = "Big HEADER"
rngActive.Font.Size = 14
rngActive.Font.Bold = True
With objActiveSheet.Range(rngActive, rngActive.Offset(0, 4)) ' 5
.Merge
.HorizontalAlignment = -4108
.VerticalAlignment = -4108 'xlVAlignCenter
.RowHeight = .RowHeight * 2
End With
'Second row
'Link to cell 2:2 and ...
Set rngActive = objActiveSheet.Cells(2, 2) 'second row - second column
rngActive = "Sub header ..."
rngActive.Font.Size = 13
rngActive.Font.Bold = True
With objActiveSheet.Range(rngActive, rngActive.Offset(0, 4)) ' 5
.Merge
.HorizontalAlignment = -4108 '-4108 'xlHAlignCenter
.VerticalAlignment = -4108 'xlVAlignCenter
.RowHeight = .RowHeight * 1.2
End With
' Start with data
'--------------------------------------------------------------------------
' Headers
'--------------------------------------------------------------------------
iRowNo = 3
Set rngActive = objActiveSheet.Cells(iRowNo, 2) '3 row - second column
With rngActive
.ColumnWidth = 30
.Borders.LineStyle = 1 '-4108 'xlContinuous 'Line
.HorizontalAlignment = -4108 'xlHAlignCenter
.Interior.Color = RGB(220, 220, 220) 'Серый цвет
End With
'3
Set rngActive = objActiveSheet.Cells(iRowNo, 3) '
rngActive = "Name 01"
With rngActive
.ColumnWidth = 20
.Borders.LineStyle = 1 'xlContinuous
.HorizontalAlignment = -4108 'xlHAlignCenter
.Interior.Color = RGB(220, 220, 220) 'Gray color
End With
'3 - Name af some thing 02
Set rngActive = objActiveSheet.Cells(iRowNo, 4) 'третья строка - второй столбец
rngActive = "Name 02"
With rngActive
.ColumnWidth = 20
.Borders.LineStyle = 1
.HorizontalAlignment = -4108 'xlHAlignCenter
.Interior.Color = RGB(220, 220, 220) 'Gray color
End With
'4 - Name af some thing 03
Set rngActive = objActiveSheet.Cells(iRowNo, 5)
rngActive = "Name 03"
With rngActive
.ColumnWidth = 20
.Borders.LineStyle = 1 'xlContinuous 'Line
.HorizontalAlignment = -4108 'xlHAlignCenter
.Interior.Color = RGB(220, 220, 220) 'Gray color
End With
'5 - Total
Set rngActive = objActiveSheet.Cells(iRowNo, 6)
rngActive = "TOTAL"
With rngActive
.ColumnWidth = 20
.Borders.LineStyle = 1 'xlContinuous 'Line
.HorizontalAlignment = -4108 'xlHAlignCenter
.Interior.Color = RGB(220, 220, 220) 'Gray color
End With
'--------------------------------------------------------------------------
'END OF Header
'--------------------------------------------------------------------------
iRowNo = 3
For i = 1 To 4
iRowNo = iRowNo + 1
sUsluga = "Servise name " & Format(i, "000") '
sUslugaName = "SN: " & Format(i, "00")
Set rngActive = objActiveSheet.Cells(iRowNo, 2) '
rngActive = "Servise Q-ty " & sUslugaName
rngActive.Borders.LineStyle = 1 'Line
Set rngActive = objActiveSheet.Cells(iRowNo, 3) '
rngActive.Borders.LineStyle = 1 'Line
rngActive = CCur(i) 'For example
'
Set rngActive = objActiveSheet.Cells(iRowNo, 4) 'row - column
rngActive.Borders.LineStyle = 1 'Line
rngActive = CCur(i) 'For example
'
Set rngActive = objActiveSheet.Cells(iRowNo, 5) 'row - column
rngActive.Borders.LineStyle = 1 'Line
rngActive = CCur(i) 'For example
'Total
Set rngActive = objActiveSheet.Cells(iRowNo, 6) 'row - column
rngActive.Borders.LineStyle = 1 'Line
rngActive.FormulaR1C1 = "=RC[-3]+RC[-2]+RC[-1]"
rngActive.Font.Bold = True
'=============================================================
'Total 2
iRowNo = iRowNo + 1
Set rngActive = objActiveSheet.Cells(iRowNo, 2) 'row - column
rngActive = "Total of ... some thing ..." & sUslugaName
With rngActive
.Borders.LineStyle = 1 'Line
End With
'
Set rngActive = objActiveSheet.Cells(iRowNo, 3) 'row - column
rngActive.Borders.LineStyle = 1 'Line
rngActive = CCur(i) 'For example
'
Set rngActive = objActiveSheet.Cells(iRowNo, 4) 'row - column
rngActive.Borders.LineStyle = 1 'Line
rngActive = CCur(i) 'For example
'
Set rngActive = objActiveSheet.Cells(iRowNo, 5) 'row - column
rngActive.Borders.LineStyle = 1 'Line
rngActive = CCur(i) 'For example
'Total 3
Set rngActive = objActiveSheet.Cells(iRowNo, 6) 'row - column
rngActive.Borders.LineStyle = 1 'Line
rngActive.FormulaR1C1 = "=RC[-3]+RC[-2]+RC[-1]"
rngActive.Font.Bold = True
Next i
'
Set rngActive = objActiveSheet.Cells(iRowNo, 2) 'row - column
With objActiveSheet.Range(rngActive, rngActive.Offset(0, 4)) ' 5
.Borders(9).LineStyle = -4119 'xlEdgeBottom = 9 & Const xlDouble = -4119 (&HFFFFEFE9)
End With
iRowNo = iRowNo + 1 '- Fix
Set rngActive = objActiveSheet.Cells(iRowNo, 2) 'строка - второй столбец
With objActiveSheet.Range(rngActive, rngActive.Offset(0, 4)) ' 5
.RowHeight = 7
End With
'--------------------------------------------------------------------------
'Tariffs
'--------------------------------------------------------------------------
For i = 1 To 4
iRowNo = iRowNo + 1
Select Case i
Case 1
sUsluga = "A18.05.002.001" '
sUslugaName = "N\D"
Case 2
sUsluga = "A18.05.011" '
sUslugaName = "N\D"
Case 3
sUsluga = "A18.30.001" '
sUslugaName = "N\D"
Case 4
sUsluga = "A18.30.001.002" '
sUslugaName = "N\D"
End Select
Set rngActive = objActiveSheet.Cells(iRowNo, 2) 'row - column
rngActive = "Tariff " & sUslugaName
rngActive.Borders.LineStyle = 1 'Line
'
Set rngActive = objActiveSheet.Cells(iRowNo, 3) 'row - column
rngActive.Borders.LineStyle = 1 'Line
'SELECT prPrice FROM dtPrices WHERE (((dtPrices.prSERVICE)="A18.05.002.001"));
rngActive = CCur(i * 12) '"ot baldy" (Rus) = ("from the bulldozer")
rngActive.NumberFormat = "#,##0.00 $" ' Format!
Next i
'--------------------------------------------------------------------------
'Total 04
'--------------------------------------------------------------------------
iRowNo = iRowNo + 1 '
Set rngActive = objActiveSheet.Cells(iRowNo, 2) 'row - column
With objActiveSheet.Range(rngActive, rngActive.Offset(0, 4)) ' 5
.Borders(9).LineStyle = -4119 'xlEdgeBottom = 9 & Const xlDouble = -4119 (&HFFFFEFE9)
.RowHeight = 7
End With
For i = 1 To 4
iRowNo = iRowNo + 1
Select Case i
Case 1
sUsluga = "A18.05.002.001" '
sUslugaName = "00" & " - " & Format(i, "00")
Case 2
sUsluga = "A18.05.011" '
sUslugaName = "00" & " - " & Format(i, "00")
Case 3
sUsluga = "A18.30.001" '
sUslugaName = "00" & " - " & Format(i, "00")
Case 4
sUsluga = "A18.30.001.002" '
sUslugaName = "00" & " - " & Format(i, "00")
End Select
Set rngActive = objActiveSheet.Cells(iRowNo, 2) 'row - column
rngActive = "Total ... " & sUslugaName
rngActive.Borders.LineStyle = 1 'Line
'
Set rngActive = objActiveSheet.Cells(iRowNo, 3) 'row - column
rngActive.Borders.LineStyle = 1 'Line
rngActive = CCur(i * 100)
rngActive.NumberFormat = "#,##0.00 $" ' Cell format
'
Set rngActive = objActiveSheet.Cells(iRowNo, 4) 'row - column
rngActive.Borders.LineStyle = 1 'Line
rngActive = CCur(i * 100)
rngActive.NumberFormat = "#,##0.00 $" ' Cell format
'
Set rngActive = objActiveSheet.Cells(iRowNo, 5) 'row - column
rngActive.Borders.LineStyle = 1 'Line
rngActive = CCur(i * 100)
rngActive.NumberFormat = "#,##0.00 $" ' Cell format
'TOTAL:
Set rngActive = objActiveSheet.Cells(iRowNo, 6)
rngActive = "=SUM(RC[-3]:RC[-1])"
With rngActive
.Borders.LineStyle = 1 'Line
.Font.Bold = True
End With
Next i
'Line
Set rngActive = objActiveSheet.Cells(iRowNo, 2) 'row - column
With objActiveSheet.Range(rngActive, rngActive.Offset(0, 4)) ' 5
.Borders(9).LineStyle = -4119 'xlEdgeBottom = 9 & Const xlDouble = -4119 (&HFFFFEFE9)
End With
'
'======================================= TOTAL =======================================
iRowNo = iRowNo + 1
Set rngActive = objActiveSheet.Cells(iRowNo, 2) '
rngActive = "Total all:"
With rngActive
.Borders.LineStyle = 1 'Line
'.NumberFormat = "#,##0.00 $" ' Cell format
.Font.Bold = True
.Font.Color = -6737101
.RowHeight = .RowHeight * 1.12
End With
'
Set rngActive = objActiveSheet.Cells(iRowNo, 3)
rngActive = "=SUM(C" & iRowNo - 4 & ":C" & iRowNo - 1 & ")"
With rngActive
.Borders.LineStyle = 1 'Line
.NumberFormat = "#,##0.00 $" ' Cell format
.Font.Bold = True
.Font.Color = -6737101
End With
'
Set rngActive = objActiveSheet.Cells(iRowNo, 4)
rngActive = "=SUM(D" & iRowNo - 4 & ":D" & iRowNo - 1 & ")"
With rngActive
.Borders.LineStyle = 1 'Line
.NumberFormat = "#,##0.00 $" ' Cell format
.Font.Bold = True
.Font.Color = -6737101
End With
'SUM
Set rngActive = objActiveSheet.Cells(iRowNo, 5)
rngActive = "=SUM(E" & iRowNo - 4 & ":E" & iRowNo - 1 & ")"
'rngActive = "=C16+C17+C18+C19"
With rngActive
.Borders.LineStyle = 1 'Line
.NumberFormat = "#,##0.00 $" ' Cell format
.Font.Bold = True
.Font.Color = -6737101
End With
'SUM
Set rngActive = objActiveSheet.Cells(iRowNo, 6)
rngActive = "=SUM(F" & iRowNo - 4 & ":F" & iRowNo - 1 & ")"
'rngActive = "=C16+C17+C18+C19"
With rngActive
.Borders.LineStyle = 1 'Line
.NumberFormat = "#,##0.00 $" ' Cell format
.Font.Bold = True
.Font.Color = -6737101
End With
If iListNo < 3 Then 'Next!
iListNo = iListNo + 1
GoTo MakeReporIntExcel_StartNewList
End If
'!
Set rngActive = objActiveSheet.Cells(1, 1) '
objExcelApp.Visible = True
'Save file to HDD.
sTemp = v & "Test000"
'Excel Window = Maximized
objExcelApp.WindowState = -4137 'xlMaximized
s = sExportFolder & "Report " & sTemp & ".xls"
objExcelApp.DisplayAlerts = False
WrkBk.SaveAs s ', 18
objExcelApp.Visible = True
MakeReporIntExcel_Bye:
DoCmd.Hourglass False 'Normal Cursor! (Arrrow)
On Error Resume Next
Set WrkBk = Nothing
Set objActiveSheet = Nothing
Set rngActive = Nothing
Set rngInput = Nothing
Set objExcelApp = Nothing
Exit Sub
MakeReporIntExcel_Err:
MsgBox "Err " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
"In SUB: MakeReporIntExcel", vbCritical, "Error in ..."
Resume MakeReporIntExcel_Bye
End Sub