That is the big problem as I said am completely new to writing a VBA
macro I was hoping for a code snippet which wich would give me some
tips on how can I do it with the existing macro. I will paste a code
snippet which is there pls advice me how to proceed. It does not
have a pivot table?
The following function (PrepareTheReport) is called from the mail
function. I need to add an extra column at the last row for evry
similar BillingDocumentNbr. There are lots of repeating
BillingDocumentNbr's with corresponding value for CumRRBilled. I
need to total up CumRRBilled for all similar BillingDocumentNbr's.
Please do me a favour and help me.
=====================================================================
' Define constants for the sheets we need to keep
Global Const PARAMSHEETNAME As String = "Parameters"
Global Const TEMPLATESHEETNAME As String = "ReportFormat"
Global Const WELCOMESHEETNAME As String = "MC Audit"
' These range names get used a lot. Having them as constants is
mostly for documentation.
Const RNAMECustomerNumber As String = "CustomerNbr"
Const RNAMEContractNumber As String = "ContractNumber"
Const RNAMESheetsToKeep As String = "SheetsToKeep"
Const RNAMEDBNames As String = "DBNames"
Const RNAMEEnvironment As String = "Environment"
Const RNAMESQLServers As String = "SQLServers"
Const RNAMETheColumns As String = "TheColumns"
Const RNAMECustomerName As String = "CustomerName"
Const RNAMECustomerNbr As String = "CustomerNbr"
Const RNAMEContractNbr As String = "ContractNbr"
Const RNAMESalesOfficeCode As String = "SalesOfficeCode"
Const RNAMESalesGroupCode As String = "SalesGroupCode"
Const RNAMEDocumentDate As String = "DocumentDate"
Const RNAMESalesOrder As String = "SalesOrder"
Const RNAMESalesOffice As String = "SalesOffice"
Const RNAMEBillingDocumentNbr As String = "BillingDocumentNbr"
Const RNAMEMCAmount As String = "MCAmount"
Const RNAMERebate As String = "Rebate"
Const RNAMESalesOrderSubTotal As String = "SalesOrderSubTotal"
Const RNAMEFinancialAdjustment As String = "FinancialAdjustment"
Const RNAMEtransaction As String = "transaction"
Const RNAMECumFinAdj As String = "CumFinAdj"
Const RNAMEMCFinAdj As String = "MCFinAdj"
Const RNAMECumMinCom As String = "CumMinCom"
Const RNAMECumEarnedRoyalty As String = "CumEarnedRoyalty"
Const RNAMEPrepaidBalance As String = "PrepaidBalance"
Const RNAMEMCInvoice As String = "MCInvoice"
Const RNAMERRInvoice As String = "RRInvoice"
Const RNAMECumMCBilled As String = "CumMCBilled"
Const RNAMECumRRBilled As String = "CumRRBilled"
Private Sub PrepareTheReport(oRPT As Worksheet)
' Organize getting the data
' put the data in place
Dim TheDB As ADODB.Connection
Dim TheData As ADODB.Recordset
' The connection string needs some values that should be in the
Parameters...
Dim oWS As Worksheet ' just because...
Dim sDBNAME As String
Dim sDBServer As String
Dim sSQL As String
Dim MiscInt As Integer
Dim MiscRange As Range
Dim RowsIn As Long
Dim coloff As Long ' offset to column
Dim ThisName As String
Dim ThisCol As Long ' the column we're interested in
Dim oFMT As Worksheet
Dim RangeDesc As String
Set oFMT = Worksheets("ReportFormat")
Set oWS = Worksheets(PARAMSHEETNAME)
sDBNAME = oWS.Range(RNAMEDBNames).Find(oWS.Range
(RNAMEEnvironment) & "rpt").Offset(0, 1)
sDBServer = oWS.Range(RNAMESQLServers).Find(oWS.Range
(RNAMEEnvironment) & "sql").Offset(0, 1)
Set TheDB = New ADODB.Connection
sSQL = "Provider=SQLOLEDB;Data Source=SQL02;Initial
Catalog=Temp_DB; Trusted_Connection=Yes"
With TheDB
' .DefaultDatabase = sDBNAME
' .Provider = "SQLOLEDB"
.ConnectionString = sSQL
.CommandTimeout = 90
.Open
End With
Set TheData = New ADODB.Recordset
sSQL = "SELECT * FROM FNMinCommitRecon_NBR('" & oWS.Range
(RNAMEContractNumber) & "')"
With TheData
Set .ActiveConnection = TheDB
.Open (sSQL)
If .State = ADODB.adStateOpen Then
If .BOF And .EOF Then
MsgBox "No rows returned. Sorry - No report"
GoTo ExitSub
End If
' Get some values and compare them to parameters
MiscInt = .Fields.Count
If MiscInt = oWS.Range(RNAMETheColumns).Rows.Count Then
Else
Debug.Print "Mistake"
GoTo ExitSub
End If
RowsIn = 0
' Every row is supposed to have the header information,
but do the setup
' on the first row, just because it's there
ThisName = RNAMECustomerName
oRPT.Range(ThisName) = TheData.Fields(ThisName)
ThisName = RNAMECustomerNbr
oRPT.Range(ThisName) = TheData.Fields(ThisName)
ThisName = RNAMEContractNbr
oRPT.Range(ThisName) = TheData.Fields(ThisName)
ThisName = RNAMESalesOfficeCode
oRPT.Range(ThisName) = TheData.Fields(ThisName)
ThisName = RNAMESalesGroupCode
oRPT.Range(ThisName) = TheData.Fields(ThisName)
Do Until .EOF
ThisName = RNAMEDocumentDate
oRPT.Range(ThisName).Offset(RowsIn, 0) =
TheData.Fields(ThisName)
ThisName = RNAMESalesOrder
oRPT.Range(ThisName).Offset(RowsIn, 0) =
TheData.Fields(ThisName)
ThisName = RNAMESalesOffice
oRPT.Range(ThisName).Offset(RowsIn, 0) =
TheData.Fields(ThisName)
ThisName = RNAMEBillingDocumentNbr
oRPT.Range(ThisName).Offset(RowsIn, 0) =
TheData.Fields(ThisName)
ThisName = RNAMEMCAmount
oRPT.Range(ThisName).Offset(RowsIn, 0) =
TheData.Fields(ThisName)
ThisName = RNAMERebate
oRPT.Range(ThisName).Offset(RowsIn, 0) =
TheData.Fields(ThisName)
ThisName = RNAMESalesOrderSubTotal
oRPT.Range(ThisName).Offset(RowsIn, 0) =
TheData.Fields(ThisName)
ThisName = RNAMEFinancialAdjustment
oRPT.Range(ThisName).Offset(RowsIn, 0) =
TheData.Fields(ThisName)
RowsIn = RowsIn + 1
.MoveNext
Loop
End If
End With
' Now fix up the Formulae
ThisName = RNAMEtransaction
oRPT.Range(oRPT.Cells(Range(ThisName).Row, Range
(ThisName).Column), oRPT.Cells(Range(ThisName).Row + RowsIn, Range
(ThisName).Column)).Select
Selection.FillDown
ThisName = RNAMECumFinAdj
oRPT.Range(oRPT.Cells(Range(ThisName).Row, Range
(ThisName).Column), oRPT.Cells(Range(ThisName).Row + RowsIn, Range
(ThisName).Column)).Select
Selection.FillDown
ThisName = RNAMEMCFinAdj
oRPT.Range(oRPT.Cells(Range(ThisName).Row, Range
(ThisName).Column), oRPT.Cells(Range(ThisName).Row + RowsIn, Range
(ThisName).Column)).Select
Selection.FillDown
ThisName = RNAMECumMinCom
oRPT.Range(oRPT.Cells(Range(ThisName).Row, Range
(ThisName).Column), oRPT.Cells(Range(ThisName).Row + RowsIn, Range
(ThisName).Column)).Select
Selection.FillDown
ThisName = RNAMECumEarnedRoyalty
oRPT.Range(oRPT.Cells(Range(ThisName).Row, Range
(ThisName).Column), oRPT.Cells(Range(ThisName).Row + RowsIn, Range
(ThisName).Column)).Select
Selection.FillDown
ThisName = RNAMEPrepaidBalance
oRPT.Range(oRPT.Cells(Range(ThisName).Row, Range
(ThisName).Column), oRPT.Cells(Range(ThisName).Row + RowsIn, Range
(ThisName).Column)).Select
Selection.FillDown
ThisName = RNAMEMCInvoice
oRPT.Range(oRPT.Cells(Range(ThisName).Row, Range
(ThisName).Column), oRPT.Cells(Range(ThisName).Row + RowsIn, Range
(ThisName).Column)).Select
Selection.FillDown
ThisName = RNAMERRInvoice
oRPT.Range(oRPT.Cells(Range(ThisName).Row, Range
(ThisName).Column), oRPT.Cells(Range(ThisName).Row + RowsIn, Range
(ThisName).Column)).Select
Selection.FillDown
ThisName = RNAMECumMCBilled
oRPT.Range(oRPT.Cells(Range(ThisName).Row, Range
(ThisName).Column), oRPT.Cells(Range(ThisName).Row + RowsIn, Range
(ThisName).Column)).Select
Selection.FillDown
ThisName = RNAMECumRRBilled
oRPT.Range(oRPT.Cells(Range(ThisName).Row, Range
(ThisName).Column), oRPT.Cells(Range(ThisName).Row + RowsIn, Range
(ThisName).Column)).Select
Selection.FillDown
' Set the print range
With oRPT.PageSetup
.PrintTitleRows = "$1:$6"
.PrintTitleColumns = ""
.PrintArea = "A6:S" & (6 + RowsIn)
.LeftFooter = "&""Arial,Bold""Microsoft Corporation
Confidential"
.CenterFooter = "&D"
.RightFooter = "Page &P of &N"
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
' .PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.FitToPagesWide = 1
.FitToPagesTall = 1000
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.25)
End With
' Put outlines around the reporting cells so it looks like
gridlines are on.
Application.Goto Reference:="Print_Area"
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
ExitSub:
' Clean up house before you go
If TheData.State = ADODB.adStateOpen Then
TheData.Close
End If
Set TheData = Nothing
If ADODB.adStateOpen = TheDB.State Then
TheDB.Close
End If
Set TheDB = Nothing
End Sub