Add reference for Microsoft active data objects - menu option Tools, Referneces
'code for main form - allows a user to enter a date range dd/mmm/yyyy
'or a responsibility code rante for the data extract.
'there are buttons to allow look up of resonsibility codes
'the codes are extracted from a DB2 data base on os/400
Option Explicit
Private Sub cbResp_Click()
If cbResp.Value = True Then
txtFrmResp.Enabled = False
txtToResp.Enabled = False
txtFrmResp.BackColor = RGB(192, 192, 192)
txtToResp.BackColor = RGB(192, 192, 192)
Else
txtFrmResp.Enabled = True
txtToResp.Enabled = True
txtFrmResp.BackColor = RGB(255, 255, 255)
txtToResp.BackColor = RGB(255, 255, 255)
End If
End Sub
Private Sub cmdPushMe_Click()
Dim frmDte As String
Dim toDte As String
Dim pFrmDate As String
Dim pToDate As String
Dim dte As Date
Dim dfrmDte As Date
Dim dtoDte As Date
Dim iFrmResp As Integer
Dim iToResp As Integer
Dim cFrmResp As String
Dim cToResp As String
If Not IsDate(txtFromDate) Then
MsgBox "Please Enter a Valid From Date", vbCritical, "Invalid Date"
Exit Sub
Else
dfrmDte = CDate(txtFromDate)
frmDte = FormatDateTime(dfrmDte, vbShortDate)
txtFromDate = DateFormat(FormatDateTime(dfrmDte, vbShortDate))
End If
If Not IsDate(txtToDate) Then
MsgBox "Please Enter a Valid To Date", vbCritical, "Invalid Date"
Exit Sub
Else
dtoDte = CDate(txtToDate)
toDte = FormatDateTime(dtoDte, vbShortDate)
txtToDate = DateFormat(FormatDateTime(dtoDte, vbShortDate))
End If
If dfrmDte > dtoDte Then
MsgBox "From Date is Greater than To Date", vbCritical, "Date Range Error"
Exit Sub
End If
If cbResp.Value = True Then
iFrmResp = 0
iToResp = 9999
Else
iFrmResp = CInt(txtFrmResp)
iToResp = CInt(txtToResp)
End If
If iToResp = 0 Then
MsgBox "Responsibility Range Incorrect", vbCritical, "Invalid Responsibiltiy Range"
Exit Sub
End If
If iToResp < iFrmResp Then
MsgBox "Responsibility Range Incorrect", vbCritical, "Invalid Responsibiltiy Range"
Exit Sub
End If
If iFrmResp > 0 Then
If iFrmResp < 1000 Or iFrmResp > 9999 Then
MsgBox "Responsibility must be between 1000 and 9999. Please Fis", vbCritical, "Invalid Responsibiltiy Range"
Exit Sub
End If
End If
If iToResp < 1000 Or iToResp > 9999 Then
MsgBox "Responsibility must be between 1000 and 9999. Please Fis", vbCritical, "Invalid Responsibiltiy Range"
Exit Sub
End If
cFrmResp = FormatNumber(iFrmResp, 0, vbTrue, vbFalse, vbFalse)
cToResp = FormatNumber(iToResp, 0, vbTrue, vbFalse, vbFalse)
txtFrmResp = cFrmResp
txtToResp = cToResp
frmMain.Repaint
frmMain.MousePointer = fmMousePointerHourGlass
frmMain.Repaint
pFrmDate = Mid(frmDte, 7, 4) + Mid(frmDte, 4, 2) + Mid(frmDte, 1, 2)
pToDate = Mid(toDte, 7, 4) + Mid(toDte, 4, 2) + Mid(toDte, 1, 2)
Module1.Main pFrmDate, pToDate, cFrmResp, cToResp
frmMain.MousePointer = fmMousePointerDefault
End
End Sub
Private Sub cmdFrmfResp_Click()
pResp = ""
frmResp.Show
If RTrim(pResp) <> "" Then
txtFrmResp = pResp
End If
End Sub
Private Sub cmdToResp_Click()
pResp = ""
frmResp.Show
If RTrim(pResp) <> "" Then
txtToResp = pResp
End If
End Sub
Private Sub UserForm_Initialize()
Dim dateToday As Date
Dim frmDate As Date
dateToday = Now()
frmDate = Now() - (365 * 4)
txtFromDate = DateFormat(FormatDateTime(frmDate, vbShortDate))
txtToDate = DateFormat(FormatDateTime(dateToday, vbShortDate))
cbResp.Value = True
txtFrmResp.Enabled = False
txtFrmResp.BackColor = RGB(192, 192, 192)
txtToResp.Enabled = False
txtToResp.BackColor = RGB(192, 192, 192)
End Sub
Function DateFormat(DateIn As String) As String
Dim m As Integer
Dim mth As String
Dim months(12) As String
months(0) = "Jan"
months(1) = "Feb"
months(2) = "Mar"
months(3) = "Apr"
months(4) = "May"
months(5) = "Jun"
months(6) = "Jul"
months(7) = "Aug"
months(8) = "Sep"
months(9) = "Oct"
months(10) = "Nov"
months(11) = "Dec"
m = CInt(Mid(DateIn, 4, 2))
m = m - 1
mth = months(m)
DateFormat = Mid(DateIn, 1, 3) + mth + Mid(DateIn, 6, 5)
End Function
' Code for the Responsibility lookup form
' =======================================
Option Explicit
Private Sub cmdReturn_Click()
Unload frmResp
End Sub
Private Sub lbResp_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim i As Integer
Dim sResp
sResp = lbResp.Value
i = InStr(1, sResp, " ")
pResp = Mid(sResp, 1, i - 1)
Unload frmResp
End Sub
Private Sub UserForm_Initialize()
Dim SQLCon As New ADODB.Connection
Dim Rs As New ADODB.Recordset
Dim Cmd As ADODB.Command
Dim objError As ADODB.Error
Dim SQLStr As String
Dim ConStr As String
Dim Error_Msg As String
Dim i As Integer
Dim RespDesc As String
Dim Error_Found As Boolean
lbResp.Clear
Set SQLCon = New ADODB.Connection
ConStr = "Provider=IBMDA400;Data Source=os400sysname;"
Error_Found = False
SQLCon.ConnectionString = ConStr
SQLCon.Open
For Each objError In SQLCon.Errors
Error_Msg = "Error #" & objError.Number & _
" " & objError.Description & vbCrLf & _
"NativeError: " & objError.NativeError & vbCrLf & _
"SQLState: " & objError.SqlState & vbCrLf & _
"Reported by: " & objError.Source & vbCrLf & _
"Help file: " & objError.HelpFile & vbCrLf & _
"Help Context ID: " & objError.HelpContext
MsgBox Error_Msg
Error_Found = True
Next
If Error_Found = True Then
Exit Sub
End If
'For Each Property In SQLCon.Properties
' Debug.Print Property.Name & " " & Property.Attributes
'Next
Rs.CursorType = adOpenDynamic
SQLStr = "SELECT MOSRES, MOSRDS from scareldta.osresp01 order by MOSRES"
On Error Resume Next
Rs.Open SQLStr, SQLCon
For Each objError In SQLCon.Errors
Error_Msg = "Error #" & objError.Number & _
" " & objError.Description & vbCrLf & _
"NativeError: " & objError.NativeError & vbCrLf & _
"SQLState: " & objError.SqlState & vbCrLf & _
"Reported by: " & objError.Source & vbCrLf & _
"Help file: " & objError.HelpFile & vbCrLf & _
"Help Context ID: " & objError.HelpContext
MsgBox Error_Msg
Error_Found = True
' Debug.Print SQLStr
Next
If Error_Found Then
Exit Sub
End If
While Not Rs.EOF
RespDesc = FormatNumber(Rs.Fields(0).Value, 0, vbFalse, vbFalse, vbFalse) + " " + Rs.Fields(1).Value
lbResp.AddItem (RespDesc)
Rs.MoveNext
Wend
End Sub
'Code to Extract Data and load it into a new workbook
'then close the Current workbook
'===============================
Option Explicit
Public pResp As String
Sub Auto_Open()
frmMain.Show
End
End Sub
'Reference: Microsoft OLE DB Active objects Library
Sub Main(fromDate As String, toDate As String, frmResp As String, ToResp As String)
Dim SQLCon As New ADODB.Connection
Dim Rs As New ADODB.Recordset
Dim Cmd As ADODB.Command
Dim objError As ADODB.Error
Dim SQLStr As String
Dim ConStr As String
Dim Error_Msg As String
Dim i As Integer
Dim lRow As Long
Dim Error_Found As Boolean
Dim xl As Excel.Application
Dim Wb As Excel.Workbook
Dim cwb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim rg As Excel.Range
Dim rg1 As Excel.Range
Dim rg2 As Excel.Range
Dim ch As Excel.ChartObject
Dim InvRef As String
Dim poLoc As String
Dim poNo As String
Dim invDate As String
Dim DueDate As String
Dim Val As Double
Dim InvTotal As Double
Dim GrandTotal As Double
Dim Ref As String
Dim Resp As String
Dim RespDesc As String
Dim SuppNo As String
Dim SuppName As String
Dim VouchDesc As String
Dim ReasonCode As String
Dim Reason As String
Dim DupInv As String
Dim DupStat As String
Dim tmp As String
Dim tmpDate As Date
Dim odDays As Long
Dim m As Integer
Dim mth As String
Dim months(12) As String
Dim Reasons(6) As String
Dim dOd0 As Double
Dim dOd1 As Double
Dim dOd2 As Double
Dim dOd3 As Double
Dim dOd4 As Double
Dim dOd5 As Double
Dim dOd6 As Double
Dim cdOd0 As Integer
Dim cdOd1 As Integer
Dim cdOd2 As Integer
Dim cdOd3 As Integer
Dim cdOd4 As Integer
Dim cdOd5 As Integer
Dim cdOd6 As Integer
Dim sRange As String
Dim ReasonDesc As String
Dim n As Integer
Dim sXRange As String
Dim sValRange As String
Dim iSuppNo As Integer
Dim SaveInvRef As String
Dim SaveSuppNo As Integer
Set xl = Excel.Application
Set cwb = ThisWorkbook
Set Wb = xl.Application.Workbooks.Add
n = Wb.Sheets.Count
xl.DisplayAlerts = False
For i = 3 To n
Wb.Sheets(3).Delete
Next i
xl.DisplayAlerts = True
Set ws = Wb.Sheets(2)
ws.Name = "Data"
Wb.Sheets(1).Name = "Summary"
months(0) = "Jan"
months(1) = "Feb"
months(2) = "Mar"
months(3) = "Apr"
months(4) = "May"
months(5) = "Jun"
months(6) = "Jul"
months(7) = "Aug"
months(8) = "Sep"
months(9) = "Oct"
months(10) = "Nov"
months(11) = "Dec"
Reasons(0) = "Sign Invoice"
Reasons(1) = "Sign Invoice & Release Order"
Reasons(2) = "Sign Invoice and Advise Purchase Order"
Reasons(3) = "Sign Invoice and Advise NEW Order"
Reasons(4) = "Release & Authorise Purchase Order"
Reasons(5) = "Miscellaneous"
Reasons(6) = "Not Defined"
Set SQLCon = New ADODB.Connection
ConStr = "Provider=IBMDA400;Data Source=os400sysname;"
Error_Found = False
SQLCon.ConnectionString = ConStr
SQLCon.Open
For Each objError In SQLCon.Errors
Error_Msg = "Error #" & objError.Number & _
" " & objError.Description & vbCrLf & _
"NativeError: " & objError.NativeError & vbCrLf & _
"SQLState: " & objError.SqlState & vbCrLf & _
"Reported by: " & objError.Source & vbCrLf & _
"Help file: " & objError.HelpFile & vbCrLf & _
"Help Context ID: " & objError.HelpContext
MsgBox Error_Msg
Error_Found = True
Next
If Error_Found = True Then
Exit Sub
End If
'For Each Property In SQLCon.Properties
' Debug.Print Property.Name & " " & Property.Attributes
'Next
Rs.CursorType = adOpenDynamic
SQLStr = "SELECT S.TVIIRF as Invoice_Ref, v.TVOPOL as PO_Loc, v.TVOPON as PO_No, " + _
"Digits(S.TVIDDT) as Invoice_Date, Digits(S.TVIIDT) as Due_Date, S.TVIITL as Invoice_Total, " + _
"H.MPCREF as Reference, H.MPCRES as Resp, R.MOSRDS as Resp_Description, " + _
"S.TVIISN as Supplier, n.MNAFNM as Supplier_Name, s.TVDESC as Vouch_Desc, ts.TVIIRF as Dup, " + _
"ts.TVISTS as Status FROM scareldta.PCVCHI as s join scareldta.pcvcho as v on " + _
"s.TVIILG = v.TVOILG and s.TVIISN = v.TVOISN and s.TVIIRF = v.TVOIRF join " + _
"scareldta.pchead as h on v.TVOPOL = h.KPCORL and v.TVOPON = h.KPCOR# left outer join " + _
"scareldta.osresp as r on h.MPCRES = r.MOSRES left outer join scareldta.nalink01 as l on l.MLNSUB = " + _
"'CR' and l.MLNTYP = 0 and l.MLNSLK = s.TVIISN left outer join scareldta.naname as n on " + _
"l.MLNNRN = n.MNANRN left outer join scareldta.pcvchi as ts on ts.TVIILG = " + _
"s.TVIILG and ts.TVIISN = s.TVIISN and ts.TVIIRF = s.TVIIRF and ts.TVISTS <> '2' " + _
"WHERE s.TVISTS = '2' and s.TVIIDT between " + _
fromDate + " and " + toDate + " and H.MPCRES between " + frmResp + " and " + ToResp + _
" order by Supplier, Invoice_Ref"
On Error Resume Next
Rs.Open SQLStr, SQLCon
For Each objError In SQLCon.Errors
Error_Msg = "Error #" & objError.Number & _
" " & objError.Description & vbCrLf & _
"NativeError: " & objError.NativeError & vbCrLf & _
"SQLState: " & objError.SqlState & vbCrLf & _
"Reported by: " & objError.Source & vbCrLf & _
"Help file: " & objError.HelpFile & vbCrLf & _
"Help Context ID: " & objError.HelpContext
MsgBox Error_Msg
Error_Found = True
' Debug.Print SQLStr
Next
If Error_Found Then
Exit Sub
End If
lRow = 1
ws.Cells(lRow, 1).Value = "Creditor"
ws.Cells(lRow, 2).Value = "Creditor's Name"
ws.Cells(lRow, 3).Value = "Invoice Date"
ws.Cells(lRow, 4).Value = "Invoice Ref"
ws.Cells(lRow, 5).Value = "Date Sent"
ws.Cells(lRow, 6).Value = "Days O/Due"
ws.Cells(lRow, 7).Value = "Amount"
ws.Cells(lRow, 8).Value = "Narative"
ws.Cells(lRow, 9).Value = "Code"
ws.Cells(lRow, 10).Value = "Reason"
ws.Cells(lRow, 11).Value = "Duplicate Inv"
ws.Cells(lRow, 12).Value = "Dup Stat"
ws.Cells(lRow, 13).Value = "Ref"
ws.Cells(lRow, 14).Value = "P/O Loc"
ws.Cells(lRow, 15).Value = "P/O No."
ws.Cells(lRow, 16).Value = "Resp"
ws.Cells(lRow, 17).Value = "Responsibility Description"
GrandTotal = 0
dOd0 = 0
dOd1 = 0
dOd2 = 0
dOd3 = 0
dOd4 = 0
dOd5 = 0
dOd6 = 0
cdOd0 = 0
cdOd1 = 0
cdOd2 = 0
cdOd3 = 0
cdOd4 = 0
cdOd5 = 0
cdOd6 = 0
lRow = 2
If Not Rs.EOF Then
SaveSuppNo = -1
SaveInvRef = ""
End If
While Not Rs.EOF
InvRef = Rs.Fields(0).Value
iSuppNo = Rs.Fields(9).Value
poLoc = Rs.Fields(1).Value
poNo = Format(Rs.Fields(2).Value, "######")
tmp = Rs.Fields(3).Value
m = CInt(Mid(tmp, 5, 2))
m = m - 1
mth = months(m)
invDate = Mid(tmp, 7, 2) + "/" + mth + "/" + Mid(tmp, 1, 4)
tmp = Rs.Fields(4).Value
m = CInt(Mid(tmp, 5, 2))
m = m - 1
mth = months(m)
DueDate = Mid(tmp, 7, 2) + "/" + mth + "/" + Mid(tmp, 1, 4)
tmpDate = CDate(DueDate)
If Now() < tmpDate Then
odDays = 0
Else
odDays = Now() - tmpDate
End If
Val = Rs.Fields(5).Value
InvTotal = Format(Val, "#########.##")
Ref = Rs.Fields(6).Value
Resp = Format(Rs.Fields(7).Value, "####")
RespDesc = Rs.Fields(8).Value
SuppNo = Format(iSuppNo, "#######")
SuppName = Rs.Fields(10).Value
VouchDesc = Rs.Fields(11).Value
If IsNull(Rs.Fields(12).Value) Then
DupInv = ""
Else
DupInv = Rs.Fields(12).Value
End If
If IsNull(Rs.Fields(13).Value) Then
DupStat = ""
Else
DupStat = Rs.Fields(13).Value
End If
ReasonCode = Mid(VouchDesc, Len(VouchDesc), 1)
ReasonDesc = ""
Select Case ReasonCode
Case "1"
ReasonDesc = Reasons(0)
Case "2"
ReasonDesc = Reasons(1)
Case "3"
ReasonDesc = Reasons(2)
Case "4"
ReasonDesc = Reasons(3)
Case "5"
ReasonDesc = Reasons(4)
Case "6"
ReasonDesc = Reasons(5)
Case Else
ReasonDesc = Reasons(6)
End Select
If SaveSuppNo = iSuppNo And SaveInvRef = InvRef Then
ws.Cells(lRow, 14).Value = poLoc
ws.Cells(lRow, 15).Value = poNo
Else
Select Case odDays
Case 0
dOd0 = dOd0 + Val
cdOd0 = cdOd0 + 1
Case 1
dOd1 = dOd1 + Val
cdOd1 = cdOd1 + 1
Case Is <= 7
dOd2 = dOd2 + Val
cdOd2 = cdOd2 + 1
Case Is <= 14
dOd3 = dOd3 + Val
cdOd3 = cdOd3 + 1
Case Is <= 21
dOd4 = dOd4 + Val
cdOd4 = cdOd4 + 1
Case Is <= 35
dOd5 = dOd5 + Val
cdOd5 = cdOd5 + 1
Case Else
dOd6 = dOd6 + Val
cdOd6 = cdOd6 + 1
End Select
GrandTotal = GrandTotal + Val
ws.Cells(lRow, 1).Value = SuppNo
ws.Cells(lRow, 2).Value = SuppName
ws.Cells(lRow, 3).Value = invDate
ws.Cells(lRow, 4).Value = InvRef
ws.Cells(lRow, 5).Value = DueDate
ws.Cells(lRow, 6).Value = Format(odDays, "#######")
ws.Cells(lRow, 7).Value = InvTotal
ws.Cells(lRow, 8).Value = VouchDesc
ws.Cells(lRow, 9).Value = " " 'ReasonCode
ws.Cells(lRow, 10).Value = "Suspended" ' ReasonDesc
ws.Cells(lRow, 11).Value = DupInv
ws.Cells(lRow, 12).Value = DupStat
ws.Cells(lRow, 13).Value = Ref
ws.Cells(lRow, 14).Value = poLoc
ws.Cells(lRow, 15).Value = poNo
ws.Cells(lRow, 16).Value = Resp
ws.Cells(lRow, 17).Value = RespDesc
End If
SaveSuppNo = iSuppNo
SaveInvRef = InvRef
Rs.MoveNext
lRow = lRow + 1
Wend
Rs.Close
lRow = lRow + 1
ws.Cells(lRow, 1).Value = "Total"
ws.Cells(lRow, 7).Value = Format(GrandTotal, "###,###,##0.00")
lRow = lRow - 2
ws.Rows("1:1").Font.Bold = True
ws.Columns("G:G").Style = "Currency"
ws.Columns("F:F").NumberFormat = "#0"
ws.Columns("A:A").NumberFormat = "#0"
ws.Columns("A:Q").Select
ws.Columns("A:Q").EntireColumn.AutoFit
ws.Columns("A:A").Select
ws.Columns("D:D").NumberFormat = "@"
ws.Columns("D:D").HorizontalAlignment = xlLeft
ws.Cells(2, 1).Select
Set rg = ws.Range(ws.Cells(2, 6), ws.Cells(lRow, 6))
sRange = rg.Address(RowAbsolute:=False, ColumnAbsolute:=False)
rg.Name = "DueDays"
Set rg = Nothing
' Now Do a Frequency distribution
'===============================
Set ws = Wb.Sheets(1)
Set rg = ws.Range(ws.Cells(1, 2), ws.Cells(3, 7))
rg.Font.Name = "Arial"
rg.Font.Size = 12
Set rg = Nothing
ws.Cells(3, 2).Value = "Frequency report for Suspended Invoices"
ws.Columns("B:B").ColumnWidth = 20.86
ws.Cells(6, 2).Value = "No days overdue"
ws.Cells(6, 3).Value = 0
ws.Cells(7, 2).Value = "Overdue by 1 Day"
ws.Cells(7, 3).Value = 1
ws.Cells(8, 2).Value = "Overdue up to 7 days"
ws.Cells(8, 3).Value = 7
ws.Cells(9, 2).Value = "Overdue up to 14 days"
ws.Cells(9, 3).Value = 14
ws.Cells(10, 2).Value = "Overdue up to 21 days"
ws.Cells(10, 3).Value = 21
ws.Cells(11, 2).Value = "Overdue up to 35 days"
ws.Cells(11, 3).Value = 35
ws.Cells(12, 2).Value = "Overdue over 35 days"
ws.Cells(13, 2).Value = "Total"
'Set rg = ws.Range(ws.Cells(6, 4), ws.Cells(12, 4))
'rg.FormulaArray = "=FREQUENCY(DueDays,C6:C11)"
'Set rg = Nothing
'Counts added in Manually
ws.Cells(6, 4) = cdOd0
ws.Cells(7, 4) = cdOd1
ws.Cells(8, 4) = cdOd2
ws.Cells(9, 4) = cdOd3
ws.Cells(10, 4) = cdOd4
ws.Cells(11, 4) = cdOd5
ws.Cells(12, 4) = cdOd6
ws.Cells(13, 4).Value = "=SUM(D6:D12)"
If ws.Cells(13, 4).Value > 0 Then
ws.Cells(6, 5).Value = "=D6/D13"
ws.Cells(7, 5).Value = "=D7/D13"
ws.Cells(8, 5).Value = "=D8/D13"
ws.Cells(9, 5).Value = "=D9/D13"
ws.Cells(10, 5).Value = "=D10/D13"
ws.Cells(11, 5).Value = "=D11/D13"
ws.Cells(12, 5).Value = "=D12/D13"
ws.Cells(13, 5).Value = "=D13/D13"
Else
ws.Cells(6, 5).Value = 0
ws.Cells(7, 5).Value = 0
ws.Cells(8, 5).Value = 0
ws.Cells(9, 5).Value = 0
ws.Cells(10, 5).Value = 0
ws.Cells(11, 5).Value = 0
ws.Cells(12, 5).Value = 0
ws.Cells(13, 5).Value = 0
End If
'Values of Distribution
ws.Columns("F:F").ColumnWidth = 14
Set rg = ws.Columns("F:F")
rg.Style = "Comma"
Set rg = Nothing
ws.Cells(6, 6).Value = dOd0
ws.Cells(7, 6).Value = dOd1
ws.Cells(8, 6).Value = dOd2
ws.Cells(9, 6).Value = dOd3
ws.Cells(10, 6).Value = dOd4
ws.Cells(11, 6).Value = dOd5
ws.Cells(12, 6).Value = dOd6
ws.Cells(13, 6).Value = dOd0 + dOd1 + dOd2 + dOd3 + dOd4 + dOd5 + dOd6
ws.Cells(5, 3).Value = "Days O/D"
ws.Cells(5, 4).Value = "Invoices"
ws.Cells(5, 5).Value = "% of Total $"
ws.Cells(5, 6).Value = "$ Value"
Set rg = ws.Columns("C:D")
rg.NumberFormat = "0"
Set rg = Nothing
Set rg = ws.Columns("E:E")
rg.Style = "Percent"
rg.NumberFormat = "0.00%"
Set rg = Nothing
' ----------
'Add Pie Chart to Sheet 1
'Create a new chart and embed it on the last worksheet
'Set Ranges of Date and Range of names of data types
'Cells(Row, column)
Set rg1 = ws.Range(Cells(6, 4), Cells(11, 4))
Set rg2 = ws.Range(Cells(6, 2), Cells(11, 2))
sXRange = rg2.Address(RowAbsolute:=False, ColumnAbsolute:=False)
sValRange = rg1.Address(RowAbsolute:=False, ColumnAbsolute:=False)
'ch chart object
Set ch = ws.ChartObjects.Add(50, 210, 300, 250)
ch.Chart.ChartType = xlPie
ch.Chart.SeriesCollection.NewSeries
ch.Chart.SeriesCollection(1).XValues = ws.Range(sXRange)
ch.Chart.SeriesCollection(1).Values = ws.Range(sValRange)
ch.Chart.HasTitle = True
ch.Chart.ChartTitle.Text = "Over Due Days Distributon"
'ch.Chart.SeriesCollection(1).ApplyDataLabels Type:=xlDataLabelsShowLabel 'ShowPercentage
ws.Cells(1, 1).Select
Set rg = Nothing
Set rg1 = Nothing
Set rg2 = Nothing
Set ch = Nothing
Set ws = Wb.Sheets(1)
ws.Activate
ws.Cells(1, 1).Select
xl.DisplayAlerts = False
Wb.SaveAs Filename:="C:\TEMP\Suspended_Invoices.xls"
xl.DisplayAlerts = True
frmMain.MousePointer = fmMousePointerDefault
frmMain.Repaint
'Windows("BAS_Exceptions_Report.xls").Activate
cwb.Activate
cwb.Sheets(1).Select
cwb.Close
End Sub