Please help with Error 9 Subscript out of range.

viperx100

New Member
Joined
Mar 18, 2011
Messages
16
Hi guys, I am kinda stuck here. I am new to this and for some reason we keep getting Error 9 when trying to run the excel file. I tried to debug the vba code and it keeps pointing me to this dead end.

Here is my code. I highlighted the error line in red. That file that stCoCPath is pointing to exists in the directory so I don't understand what the issue here is. Could the fact that it is a Excel 97-2003 file be the problem? Our Excel open automatically in Compatibility Mode so there shouldn't be an issue with that. Would changing Workbooks to ActiveWorkbooks do the trick?

Rich (BB code):
Sub WkbksInit()
Dim wkb As Workbook
Dim wks As Worksheet
Dim fs As Variant
Dim icount As Long
Dim i As Long
 
Call SetDepconDir 'Set PV "stDepconDir" to DEPCON Directory Path
Call SetOfficeNm 'Set PV "stCoCPath" to Overview File Name Path
Set wkb = Workbooks(stCoCPath)
If wkb Is Nothing Then
Workbooks.Open (stCoCPath)
End If
'---------------------------------------------------------
'Set the workbook object variables for all open workbooks
'---------------------------------------------------------
For Each wkb In Workbooks
If InStr(1, wkb.Name, "A67.") = 0 Then
Set wkb2 = wkb 'Set Public Variable Wkb2
stA67Nm = wkb2.Name
ElseIf InStr(1, wkb.Name, "BOSSNAPS") = 1 Then
Set wkb1 = wkb 'Set Public Variable Wkb1
stMacroNm = wkb1.Name
stMacroDir = ActiveWorkbook.Path
ElseIf InStr(1, wkb.Name, "CoC_") = 1 Then
Set Wkb4 = wkb 'Set Public Variable Wkb4
stWkb4Name = Wkb4.Name 'Set up the Public Variable
End If
Next wkb
'-----------------------------------------------------------------------------
'Test to see if the CoC Report has already been integrated into the A67 report
'-----------------------------------------------------------------------------
wkb2.Activate
Worksheets("LOCCS_ALL").Activate
icount = Range("$A1").CurrentRegion.Rows.Count
blCoCIntegrated = False
For i = 1 To icount
If IsEmpty(Range("Database").Cells(i, 2).Value) Then
blCoCIntegrated = True
Exit For
End If
Next i
End Sub

Thank you. Any help would be greatly appreciated.

Dmitriy
 
Last edited by a moderator:

Excel Facts

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).
Have you made the stCoCPath a public variable? Just because you set the variable in one macro does not mean that it is set in all of them.
 
Upvote 0
Hi Kristy,

Yes I did. Here is the declatation at the beginning of my module:

Public stCoCPath As String
 
Upvote 0
Workbook object variables refer only to workbooks open in the current instance of Excel, not to workbooks on disk.

The string should include the workbook name only, not the path.

EDIT: To clarify, when you open a workbook, you do need the full path and name, unless it's in the current directory.
 
Last edited:
Upvote 0
Here is how it is originally set:

Sub CoCSetup()
'-------------------------------------------------------------------
'If J:\DEPCON\"COC_?????.xls" exists then append it to the A67 report
'that was created by SUB FormatLOCCSALL.
'-------------------------------------------------------------------
Dim i As Long, j As Long, n As Long
Dim wkb As Workbook
Dim rgCOC As Range, rgA67 As Range
Dim fs As Variant
Dim lLastA67Row As Long
Dim lLastCoCRow As Long
Dim blCoC2004Text As Boolean
Dim blCoC2004Xls As Boolean
Dim bldebug As Boolean
Dim stA67WkBk As String
Dim t As Single
t = Timer

Application.ScreenUpdating = False
Set wkb = Workbooks.Open(Filename:=stCoCPath)
wkb.Worksheets("Sheet1").Activate
Set rgCOC = Range("$A2").CurrentRegion
Set wkb2 = Workbooks.Open(Filename:=stDepconFullNm & ".xls")
Workbooks(wkb2.Name).Worksheets("LOCCS_ALL").Activate
Set rgA67 = Range("$A1").CurrentRegion
lLastCoCRow = rgCOC.Rows.Count
lLastA67Row = rgA67.Rows.Count
'----------------------------------------------------
'Copy/Append the COC_2004.xls rows over to A67 report
'----------------------------------------------------
For i = 1 To lLastCoCRow - 1
j = lLastA67Row + i
n = i + 1
rgA67.Cells(j, 1).Value = rgCOC.Cells(n, 4) 'LOCCS_Project#
rgA67.Cells(j, 3).Value = rgCOC.Cells(n, 17) 'Year
rgA67.Cells(j, 4).Value = rgCOC.Cells(n, 15) 'State
rgA67.Cells(j, 5).Value = rgCOC.Cells(n, 18) 'Program
rgA67.Cells(j, 6).Value = rgCOC.Cells(n, 8) 'CoC Applicant Name
rgA67.Cells(j, 7).Value = "Not in LOCCS-From CoC Overview Report" 'GRANTEE_TID
rgA67.Cells(j, 10).Value = rgCOC.Cells(n, 6) 'LOCCS_Term
rgA67.Cells(j, 14).Value = rgCOC.Cells(n, 12) 'LOCCS Authorized
rgA67.Cells(j, 15).Value = 0 'LOCCS Disbursed
rgA67.Cells(j, 16).Value = rgCOC.Cells(n, 12) 'LOCCS Balance
rgA67.Cells(j, 17).Value = dtRptDate 'LOCC_RPTDATE
rgA67.Cells(j, 18).Value = rgCOC.Cells(n, 19) 'BLICODES
If rgCOC.Cells(n, 20).Value = "CANCELLED" Then 'Test "Status" field ':121905
rgA67.Cells(j, 23).Value = "FALSE" 'Cancelled Grant
Else
rgA67.Cells(j, 23).Value = "TRUE" 'ActiveGrant
End If
rgA67.Cells(j, 24).Value = rgCOC.Cells(n, 3) 'CoC Continuum Name ':123106
rgA67.Cells(j, 25).Value = rgCOC.Cells(n, 1) 'CoCPID
rgA67.Cells(j, 26).Value = rgCOC.Cells(n, 5) 'CoCProgram Code
rgA67.Cells(j, 27).Value = rgCOC.Cells(n, 7) 'CoCComponent
rgA67.Cells(j, 28).Value = rgCOC.Cells(n, 6) 'CoC Term
rgA67.Cells(j, 29).Value = rgCOC.Cells(n, 8) 'CoC Applicant Name
rgA67.Cells(j, 30).Value = rgCOC.Cells(n, 9) 'CoC Sponsor
rgA67.Cells(j, 31).Value = rgCOC.Cells(n, 10) 'CoC Project Name
rgA67.Cells(j, 32).Value = rgCOC.Cells(n, 12) 'CoC Award
rgA67.Cells(j, 33).Value = rgCOC.Cells(n, 16) 'CoC Continuum Name
rgA67.Cells(j, 34).Value = rgCOC.Cells(n, 20) 'Status
rgA67.Cells(j, 35).Value = rgCOC.Cells(n, 13) 'Rep
rgA67.Cells(j, 36).Value = rgCOC.Cells(n, 21) 'User1
rgA67.Cells(j, 37).Value = rgCOC.Cells(n, 22) 'User2
rgA67.Cells(j, 38).Value = rgCOC.Cells(n, 23) 'User3
Next i

With rgA67
.Resize(.Rows.Count + lLastCoCRow).Name = "Database"
End With
'---------------------------------------------------------------------------
'Sort the A67 report so that all duplicate project numbers will be together
'for CoC_Merge subroutine
'---------------------------------------------------------------------------
'Application.ScreenUpdating = False

Range("$A1").CurrentRegion.Select
Selection.Sort Key1:=Range("$A2"), Order1:=xlAscending, Key2:=Range("$A2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
ActiveWorkbook.Save
Workbooks(Wkb4.Name).Close SaveChanges:=True
wkb.Close
Workbooks(wkb2.Name).Activate
Debug.Print "CoCSetup", , Format(Timer - t, "#0.#00")
End Sub
 
Upvote 0
You don't show where stCoCPath or stDepconFullNm are initialized. Many variables are not declared in the code you posted.

If you don't have Option Explicit at the top of each module, this would be a good time to add it, and declare all variables in appropriate scope.
 
Upvote 0
Rich (BB code):
Option Explicit
Public Const FieldNamesCnt As Integer = 127 'Add 1 (128)
Public Const CoC_RecCnt As Integer = 14     'Actually "15" with zero position
Public Const BLIFldCnt As Integer = 29      'Add 1 (30)
Public Const LOCCSFldCnt As Integer = 22    'Add 1 (23)
Public Const iFOCnt As Integer = 45
Public stFieldNames(60) As String   ':021306 Rename A67 Fields
Public vTestAllArray() As Variant
Public vrPIN(1000, 13) As Variant
Public vrA67() As Variant
Public vrCocNames As Variant        'Destination for array stored in a Name
Public A67AG_year                   'Year text box value in ufActiveGrants
Public A67FileSelection As String       'The Last Selected A67 Report in the form
Public A67NewestRptDate As Date
Public A67NewestRptNm As String           'A67 report with most recent date stamp
Public A67NoReports As Boolean      'There are no A67 Reports to analyze
Public A67Reports(21) As String     'List of A67*.XLS files in Working Directory
Public Activity As String           'Equal to Program Except for SPC (SRA,TRA,PRA,PRAW)
Public BKP_MostRecent As Date       'Most Recent A67*.BKP report date
Public blA67Reports As Boolean
Public blA67Updated As Boolean      'A67 Update flag from Sub A67Setup(082605E)
Public blAbort As Boolean
Public blCoCIntegrated              'CoC_2004.xls file integrated into A67 worksheet
Public stGrantName As String        'WKb3 field 01
Public stProgram As String          'Wkb3 field 05
Public blSHP As Boolean             'Wkb3 field 05
Public blSPC As Boolean             'Wkb3 field 05
Public blYB As Boolean              'Wkb3 field 05
Public blHOPWA As Boolean           'Wkb3 field 05
Public blSHPNew As Boolean          'Wkb3 field 06
Public blSHPR As Boolean            'Wkb3 field 06
Public blSPCNew As Boolean          'Wkb3 field 06
Public blSPCR As Boolean            'Wkb3 field 06
Public iYear As Integer             'Wkb3 field 07
Public blNotinLOCCS As Boolean      'Wkb3 field 09
Public blEffDate As Boolean         'Wkb3 field 13
Public blNoStartDate As Boolean     'Wkb3 field 14
Public iTerm As Integer             'Wkb3 field 15
Public dtExpDate As Date            'Wkb3 field 16
Public blExpDate As Boolean         'Wkb3 field 16
Public blValidExpDate As Boolean    'Wkb3 field 16
Public iMonthsElapsed As Integer    'Wkb3 field 17
Public stBLICodes As String         'Wkb3 field 19
Public blBLICodes As Boolean        'Wkb3 field 19
Public blACQ As Boolean             'Wkb3 field 19
Public blREH As Boolean             'Wkb3 field 19
Public blNC As Boolean              'Wkb3 field 19
Public blSS As Boolean              'Wkb3 field 19
Public blHMIS As Boolean            'Wkb3 field 19
Public blOPER As Boolean            'Wkb3 field 19
Public blLEASE As Boolean           'Wkb3 field 19
Public blSuppServices As Boolean    'Wkb3 field 19
Public blConstruction As Boolean    'Wkb3 field 19
Public dbAward As Double            'Wkb3 field 20
Public dbSpent As Double            'Wkb3 field 21
Public dbBalance As Double          'Wkb3 field 22
Public dbPctTermExp As Double       'Wkb3 field 24
Public dbPctAwardSpent As Double    'Wkb3 field 25
Public stPgmCode As String          'Wkb3 field 26
Public stPgmType As String          'Wkb3 field 27
Public blPH As Boolean              'Wkb3 field 27
Public blPRAW As Boolean            'Wkb3 field 27
Public iCoCTerm As Integer          'Wkb3 field 31
Public stStatus As String           'Wkb3 field 35
Public blCancel As Boolean          'Wkb3 field 34
Public blClosed As Boolean          'Wkb3 field 34
Public blEnvReview As Boolean       'Wkb3 field 34
Public blSiteControl As Boolean     'Wkb3 field 34
Public stCoCArray(1, 100) As String     'Wkb3 field ??
Public blCovenant As Boolean        'Wkb3 field 34
Public blCoCNewYear As Boolean
Public blCoCReports As Boolean
Public blCoCRptExists               'CoC Overview Report exists in Macro Dir?
Public blCoCUpdated As Boolean      'CoC Update flag from Sub CoCStatus(082605E)
Public blDepConDir As Boolean
Public blDepConFiles As Boolean
Public BLICodes(7, 29) As Variant
Public blNewDepcon As Boolean
Public blNoCoCReports As Boolean    'True if no COC Overview files exist in Depcon
Public blTestAll As Boolean
Public BosnapDir As String
Public BosnapFirstOpen As Boolean   'Will be true after first pass of fm_BOSSNAPS
Public BosnapNm As String
Public BosnapPath As String
Public CoC_Rec(CoC_RecCnt) As Variant
Public CoCLineBuf(125) As String   'Contains one complete CoC Report Line/Record
Public dtA67xlsDate As Date        'The date of the newest A67.*.xls Report
Public dtDepconDate As Date        'The date of the newest DEPCON monthly report group
Public dtRptDate As Date            'LOCCS Report Date from A67 date string (i.e.05082004)
Public EOMacro As Variant
Public FDest As String              'Filename to save Final text and xls files
Public Filecnt, DBG As Single
Public FileOut_nm As String         'Text file containing all A67 reports for one month
Public HPACRec(30) As Variant
Public iAbort As Integer            'Abort Error Message # and > 0 Abort Flag
Public iButtonNmbr                  'Button Nmbr for VB "SELECT CASE"
Public iCoCNewYear As Integer       'Most Recent CoC Overview File from HQ
Public iCoCOfficeYear As Integer    'DEBUG VARIABLE - CLEAN THIS UP 121005
Public iCoCYear As Integer          'Most Recent Year in Master Office File
Public iExpYear As Integer          'Operator Input variable for Expiring Grant Year
Public iRptYear As Integer          'From A67 file name using SetWorkbooks
Public LOCCS_Rec(LOCCSFldCnt) As Variant 'Record values to be written
Public LocFiles(3, 125) As String
Public MostRecent As Date           'Most Recent Report Date as "date" value
Public MultiRpts As Variant         'Will be "True" if there are two or more months of LOCCS Reports
Public MyDrive, MyDir As String
Public Office As String             'The CPD Office Name on A67 reports
Public PgmAbort As Integer
Public Program As String            'SHP,SPC,YB,HPAC
Public PtNm As String               'Report Name (PT1, PT2, PT3, etc)
Public PublicMsg As String
Public Retstring As String
Public rgDB3 As Range               'Wkb3 Database as Range
Public RptDate As String
Public SPCRec(30) As Variant
Public sSTButton As Single
Public stA67FullNm As String       'The Full Pathname string for the A67*.xls workbook
Public stA67Nm As String           'The Filename string for the A67*.xls workbook
Public stA67WkbName As String
Public stA67xlsDate As String      'Date of newest A67 report as mmddyyyy
Public stbutton As String          'Button category + Program "Active Grants.SPC", etc
Public stCoCFullNm As String       'Full Patname for COC_????.XLS Overview Report
Public stCoCName As String          'CoC filename from Sub SetOfficeNm(082605E)
Public stCoCNewYearPath As String   'New 2005+ CoC Overview Report from HQ
Public stCoCPath As String
Public stCPDOffice As String
Public stCPDOffices(1, iFOCnt)
Public stDepconDate As String      'The string date without "/" delimiter of the newest Depcon monthly group
Public stDepconDatex As String     'The string date of the newest Depcon monthly group
Public stDEPCONDir As String
Public stDepConFileNm As String    'The DepCon File Name to be saved
Public stDepconFullNm As String       'Full Depcon File name to be saved
Public stFilterFullNm              'Full Pathname of Filter being save
Public stFilterNm                  'Filter file name
Public stMacroDir As String        'The Directory Path Name string for the BOSMAC MACRO workbook
Public stMacroFullNm As String     'The Full Pathname string for the BOSMAC MACRO workbook
Public stMacroNm As String         'The Filename string for the BOSMAC MACRO workbook
Public stMostRecent As String       'Most Recent Report Date as "string" value
Public stMsg    As String           'For Messages
Public stNationalName As String
Public stHQDirs(43) As String       'List of Field Office Names supplied by HQ for their HQ DEPCON folders
Public stTextBoxNm As String       'Name of Text Box Object used by Sub CopyTextBox()
Public stWkb3Name As String        'Name of "Filtered" Workbook to be saved
Public stWkb4Name As String        '"CoC_2004.xls" if open
Public tsout, tsin
Public vButtonsArray(3, 25)
Public wkb1 As Workbook            'The BOSMAC Workbook object
Public wkb2 As Workbook            'The A67*.xls Workbook object
Public wkb3 As Workbook            'The "Filtered" Workbook object
Public Wkb4 As Workbook            'The "CoC_2004.xls" Workbook object
Public Wkb5 As Workbook            'The "CoC2005+*.xls" New Overview Report Workbook object
Public YBRec(30) As Variant
Public MsgPublic As String          'For UserForm1 DisplayMsg() public routine
Public vaSHPRenewals As Variant     ':090429 Array for Speed-Up of SHP Renewal Processing
 
Sub DelWorkFiles()
'   Public stDepConFileNm As String    'The DepCon File Name to be saved
    Dim fs As Variant
    Dim stA67All As String
    Dim stLoccsAll As String
    Dim stA67Office As String
    Dim t As Single
    t = Timer
 
 
    stMacroFullNm = ThisWorkbook.FullName       'Set Public Variable
    stMacroDir = ThisWorkbook.Path              'Set Public Variable
    stMacroNm = ThisWorkbook.Name
    stA67All = stMacroDir + "\A67_All.txt"
    stLoccsAll = stMacroDir + "\LOCCS_All.txt"
 
    Set fs = CreateObject("Scripting.FileSystemObject")
    If (fs.FileExists(stA67All)) Then Kill (stA67All)
    If (fs.FileExists(stLoccsAll)) Then Kill (stLoccsAll)
    Debug.Print "    DelWorkFiles", Format((Timer - t), "#0.#00")
End Sub
Sub Parse_LOCCSAll()
 
' Macro  SHP_052403
' Macro recorded 5/24/2003 by Richard Therrien-HUD Boston CPD Office
' Email Richard_H._Therrien@hud.gov
 
'Public Filecnt As Single
'Public LocFiles(3, 125) As String
'Public RptDate As String
 
'-----------------------------------
'Convert the input file "A67_All.txt" to an output file "LOCCS_All.txt" that has all
'LOCCS report data parsed and available for a second pass to perform detailed analysis
'-----------------------------------
 
    Const ForReading = 1, ForAppending = 8
    Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
 
 
    Dim FirstLine As Boolean
    Dim fs As Variant
    Dim BLICode As Integer, n As Integer
    Dim Retstring As String, t As String, ReportDate As String
    Dim Authorized, Disbursed, Balance, GT_Authorized, GT_Disbursed As Currency
    Dim FilesArray(7)
    Dim fsin, fsout, fin, fout, Found, i
    Dim fsout1, fout1
    Dim stFileIn As String
    Dim stFileOut As String
    Dim t1 As Single
 
    n = BLIFldCnt  'This is the limit for budget categories
    t = Chr(9)
    t1 = Timer
'-----------------------------------
'Set up input file "A67_All.txt" and output file "LOCCS_All.txt"
'-----------------------------------
    Set fs = CreateObject("Scripting.FileSystemObject")
    stFileIn = stMacroDir + "\A67_ALL.txt"
    stFileOut = stMacroDir + "\LOCCS_ALL.txt"
    Set tsout = fs.OpenTextFile(stFileOut, ForAppending, True, TristateFalse)        'Create a text stream file system object
    Set tsin = fs.OpenTextFile(stFileIn, ForReading, TristateFalse)
    tsout.Writeline (Fn_PrtHdr)
 
'-----------------------------------------------------------------------------------
'Main Loop - Read and process the composite of all A67 Reports - file "A67_All.txt"
'-----------------------------------------------------------------------------------
    FirstLine = True
    Do While tsin.AtEndOfStream <> True
        Retstring = tsin.ReadLine
        '----------------------------------------------------------
        If FirstLine = True Then    'The FirstLine in the "A67All.txt" line is a A67 ID line
        '----------------------------------------------------------
            Program = Trim(Mid(Retstring, 10, 8))  'Update the local Program Type parameter
 
            Retstring = tsin.ReadLine
            Call Parse_GrantLine(Retstring)
            FirstLine = False
            For i = 0 To BLIFldCnt
               BLICodes(1, i) = ""
               BLICodes(2, i) = "0"
               BLICodes(3, i) = "0"
               BLICodes(4, i) = "0"
               BLICodes(5, i) = Empty
               BLICodes(6, i) = Empty
               BLICodes(7, i) = Empty
            Next i
        '----------------------------------------------------------------------------------------
        ElseIf (Trim(Mid(Retstring, 70, 8)) = "Eff Dt:") Or (Trim(Mid(Retstring, 1, 5)) = "Line") Then
        'This is the start of a new record - Process the last record and append it to output file
        '----------------------------------------------------------------------------------------
            Call Parse_LOCCSRec
            If Mid(LOCCS_Rec(0), 1, 7) = "Program" Then
 
            Else
            tsout.Writeline (Fn_RecordOut)
            End If
            '------------------------------------------------------------------------------------
            'Clear all the budget variables in preparation for the next write of an Output record
            '------------------------------------------------------------------------------------
            For i = 0 To BLIFldCnt
                BLICodes(2, i) = "0"
                BLICodes(3, i) = "0"
                BLICodes(4, i) = "0"
                BLICodes(1, i) = ""
            Next i
            If (Trim(Mid(Retstring, 70, 8)) = "Eff Dt:") Then
                Call Parse_GrantLine(Retstring) 'Parse the current Grant line in the Retstring input buffer in preparation for next Output Record
            End If
        '-------------------------------------------------------------------------------------------------
        ElseIf Trim(Mid(Retstring, 1, 6)) = "EOFEOF" Then   'The last record is the Report Total lines
        '-------------------------------------------------------------------------------------------------
            Call Parse_BLITotals
            FirstLine = True 'Prepare for the first line of the next file
        '---------------------------------------------------------------------------
        ElseIf Len(Trim(Mid(Retstring, 1, 11))) = 4 Then    'This is a BLI Code line
        '---------------------------------------------------------------------------
            BLICode = CInt(Trim(Mid(Retstring, 1, 11)))
            If BLICode > 999 And BLICode < 3200 Then 'This is a budget line for the current record being processed
                Call Parse_BLILine(Retstring)
                If PgmAbort = 1 Then Exit Do
            End If
        '---------------------------------------------------------------------------
        ElseIf Trim(Mid(Retstring, 1, 35)) = "TOTAL" Then  'This is a "TOTALS" line - for future use only
        '---------------------------------------------------------------------------
        End If
    Loop
    tsin.Close
    tsout.Close
Lastline:
    Debug.Print "    Parse_LOCCSALL", Format((Timer - t1), "#0.#00"), "Create Comma-delimited text file version of A67"
End Sub
Sub Subtotals()
    Dim RW As String, CL As String, MyRange As String
    Dim lr As Integer
    Dim t As Single
    t = Timer
 
'    ActiveSheet.ShowAllData
 
'Insert the Subtotal formulas at end of the filtered data
    Range("A1").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    RW = Trim(Str(Selection.Rows.Count))
    CL = Trim(Str(Selection.Columns.Count))
    MyRange = "=LOCCS_ALL!R1C1:R" + RW + "C" + CL
    ActiveWorkbook.Names.Add Name:="Database", RefersToR1C1:= _
        "=LOCCS_ALL!R1C1:R" + RW + "C" + CL
    lr = RW + 2
    ActiveSheet.Range(Cells(lr, 1), Cells(lr, 1)).Formula = "=SubTotal(3,A2:A" + RW + ")"
    ActiveSheet.Range(Cells(lr, 14), Cells(lr, 14)).Formula = "=Subtotal(9,N2:N" + RW + ")"
    'ActiveSheet.Range(Cells(lr, 15), Cells(lr, 15)).Formula = "=Subtotal(9,O2:O" + RW + ")"
    'ActiveSheet.Range(Cells(lr, 16), Cells(lr, 16)).Formula = "=Subtotal(9,P2:P" + RW + ")"
    Cells(lr, 14).Select
    Selection.Copy
    Range(Cells(lr, 15), Cells(lr, 16)).Select
    ActiveSheet.Paste
    Range(Cells(lr, 81), Cells(lr, 82)).Select
    ActiveSheet.Paste
    Range("A1").Select
    Selection.AutoFilter
    Debug.Print "    Subtotals", , Format((Timer - t), "#0.#00"), "Set up A67 Subtotals"
End Sub
Sub FILTERSUBTOTALS()
    Dim RW As String, CL As String, MyRange As String
    Dim lr As Integer
    Dim t As Single
 
    Application.ScreenUpdating = False
    t = Timer
'Insert the Subtotal formulas at end of the filtered data
    Range("A1").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    RW = Trim(Str(Selection.Rows.Count + 1))    'Add 1 to move beyond field names row
    CL = Trim(Str(Selection.Columns.Count))
    lr = RW + 1
    ActiveSheet.Range(Cells(lr, 1), Cells(lr, 1)).Formula = "=SubTotal(3,A2:A" + RW + ")"
    ActiveSheet.Range(Cells(lr, 12), Cells(lr, 12)).Formula = "=Subtotal(3,L2:L" + RW + ")"
    ActiveSheet.Range(Cells(lr, 20), Cells(lr, 20)).Formula = "=Subtotal(9,T2:T" + RW + ")"
    ActiveSheet.Range(Cells(lr, 21), Cells(lr, 21)).Formula = "=Subtotal(9,U2:U" + RW + ")"
    ActiveSheet.Range(Cells(lr, 22), Cells(lr, 22)).Formula = "=Subtotal(9,V2:V" + RW + ")"
    ActiveSheet.Range(Cells(lr, 53), Cells(lr, 53)).Formula = "=Subtotal(9,BA2:BA" + RW + ")" ':021006
    ActiveSheet.Range(Cells(lr, 54), Cells(lr, 54)).Formula = "=Subtotal(9,BB2:BB" + RW + ")" ':021006
    ActiveSheet.Range(Cells(1, 20), Cells(1, 22)).EntireColumn.NumberFormat = "$#,##0.00" 'Authorized,Disbursed,Balance
    fmProgress.pcProgress (85)
    Debug.Print "FilterSubtotals", Format(Timer - t, "#0.#00"); "  Insert Subtotal Formulas after last row"
End Sub
Sub Format_ClearErrorWindow()
    Worksheets("Macros").Activate
'    Range("AR1").Select
'    Selection.Copy
    Range("AT2:BV5").Select
'        Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
'        False, Transpose:=False
'    Application.CutCopyMode = False
    Selection.ClearContents
    Range("B1").Select
End Sub
Sub Format_ErrorWindow(Msg As String)
    If wkb1 Is Nothing Then Set wkb1 = ThisWorkbook
    wkb1.Activate
    Worksheets("Macros").Activate
    Range("AN2").Select
    With Selection
        .Value = Msg
        .Font.ColorIndex = 20
        .Font.Bold = True
        .Name = "Arial"
        .Font.Size = 10
        .Interior.ColorIndex = 50
        .Interior.Pattern = xlSolid
        .Interior.PatternColorIndex = xlAutomatic
    End With
    Range("AN2:BN5").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = False
    End With
 
Range("AN2:BN5").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlNarrow
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlNarrow
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlNarrow
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlNarrow
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Font.ColorIndex = 2
    Selection.Merge
    Range("B1").Select
End Sub
Sub Format_LOCCSAll()
'-----------------------------------------------------------------------------
'Open the "LOCCS_ALL.txt" file, convert it to EXCEL, format it then Save it as
'"A67.Office.Date.xls". Exit with Workbook object WKB2 set to A67.
'-----------------------------------------------------------------------------
    Dim fs As Variant, Style As Variant, Response As Variant
    Dim ThisDir As String, lr As String, Msg As String, Title As String
    Dim Message1 As String
    Dim stFileIn As String
    Dim t As Single
'------------------------------------------------------------------------------------
'All SHP& SPC reports have been parsed and written to LOCCS_ALL.txt as tab-delimited records
'Import the tab-delimited text file just created and immediately save it as
'A67R1.Office.date.xls without formatting.  This allows WKB2 to be set immediately
'------------------------------------------------------------------------------------
    t = Timer
    Application.ScreenUpdating = False
    Workbooks.OpenText Filename:=wkb1.Path + "\LOCCS_All.txt"
    Set wkb2 = ActiveWorkbook
 
 
    fmProgress.pcProgress (50)
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .CenterHeader = "&""Arial,Bold""&14BOSSNAPS&12&Xplus"
        .CenterFooter = "&P of &N"
        .RightFooter = "&F"
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(1)
        .BottomMargin = Application.InchesToPoints(1)
        .HeaderMargin = Application.InchesToPoints(0.5)
        .FooterMargin = Application.InchesToPoints(0.5)
        .PrintGridlines = True
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 100
    End With
    Application.ScreenUpdating = False
    Range("A1").Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Application.ScreenUpdating = False
    Range("$A1").Select
    ActiveWindow.SplitRow = 1
    ActiveWindow.SplitColumn = 1
    ActiveWindow.FreezePanes = True
    Range("C1").Select
    Application.DisplayAlerts = False
    stA67FullNm = stDepconFullNm            'Set the PV stA67FullNm
    ActiveWorkbook.SaveAs Filename:=stDepconFullNm + ".xls", FileFormat:=xlNormal
    Application.DisplayAlerts = True
    Set wkb2 = ActiveWorkbook
    Debug.Print "    Format_LOCCSALL", Format((Timer - t), "#0.#00"), "Convert to EXCEL & format page setup"
End Sub
Sub FormatPage()
    '----------------------------------------------------
    'Formats the Page of the active filter sheet "Sheet1"
    '----------------------------------------------------
 
    Dim Rng As Range
    Dim t As Single
    Dim stPrintArea  As String
 
    t = Timer
    Set Rng = Range("$A$1").CurrentRegion
    stPrintArea = Rng.Address
    Application.ScreenUpdating = False
    ActiveSheet.PageSetup.PrintArea = stPrintArea
    With Workbooks(stWkb3Name).Worksheets(ActiveSheet.Name).PageSetup
        .PrintTitleRows = "$1:$1"
        .RightHeader = "&""Arial,Bold""&14BOSSNAPS&12&Xplus"
        .LeftHeader = "&""Arial,Bold""&16&F"
        .CenterFooter = "&P of &N"
        .RightFooter = "&F"
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(1)
        .BottomMargin = Application.InchesToPoints(1)
        .HeaderMargin = Application.InchesToPoints(0.5)
        .FooterMargin = Application.InchesToPoints(0.5)
        .PrintGridlines = True
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 100
    End With
    Debug.Print "FormatPage", , Format((Timer - t), "#0.#00"); "  Formats the Page of the active filter sheet "
End Sub
Function Fn_Year(Retstring As String)
Dim Char3 As String, Char4 As String, Char5 As String, Char6 As String, Char7 As String
Dim EffDate As String, Yeardigit As String, Grant_Nmber As String
Dim EffYear As Integer
Dim stYYY As String
Dim stGrantName As String
stGrantName = Trim(Mid(Retstring, 1, 16))
If Len(stGrantName) < 15 Then
    Char3 = Mid(Retstring, 3, 1)
    Char4 = Mid(Retstring, 4, 1)
    Char5 = Mid(Retstring, 5, 1)
    Char6 = Mid(Retstring, 6, 1)
    Char7 = Mid(Retstring, 7, 1)
    stYYY = Mid(Retstring, 5, 3)
Else    '---This grant# is for 2008 & later---
    If IsDate(LOCCS_Rec(7)) Then
        Fn_Year = Str(Year(LOCCS_Rec(7)))   '---Project is defined to LOCCS, Use Effective date for Project Year
                                            '---This date will be replaced with CoC Year if a CoC Master file
                                            '---contains this project
    Else
        Fn_Year = "????"    '---Project not defined to LOCCS. Must use the CoC Date in next step with SUB CoC_Merge
    End If
    GoTo ExitFunction
End If
EffDate = Trim(Mid(Retstring, 79, 10))
If LOCCS_Rec(10) = "1/1/100" Then LOCCS_Rec(10) = "1/1/1901"
If Program = "YB" Then
    If Mid(Retstring, 2, 1) = "9" Then
        Fn_Year = "19" + Mid(Retstring, 2, 2)
    Else: Fn_Year = "20" + Mid(Retstring, 2, 2)
    End If
 
ElseIf Program = "HPAC" Then
    If Char5 = "H" Then
        Fn_Year = "19" + Char6 + Char7
    ElseIf Char3 = "H" And Char4 = "9" Then
        Fn_Year = "19" + Char4 + Char5
    ElseIf Char3 = "H" And Char5 < "9" Then
        Fn_Year = "200" + Char5
    End If
 
ElseIf Program = "SHP" Then
    Select Case stYYY
        Case "B00" To "B04": Fn_Year = "2000"
        Case "B10" To "B14": Fn_Year = "2001"
        Case "B20" To "B24": Fn_Year = "2002"
        Case "B30" To "B34": Fn_Year = "2003"
        Case "B40" To "B44": Fn_Year = "2004"
        Case "B50" To "B54": Fn_Year = "2005"
        Case "B60" To "B64": Fn_Year = "2006"
        Case "B70" To "B74": Fn_Year = "2007"   ':090503 Fix for 2007 Program Year
        'Case "2008":         Fn_Year = "2008"  '????
        'Case "2009":         Fn_Year = "2009"
        'Case "2010":         Fn_Year = "2010"
        'Case "2011":         Fn_Year = "2011"
        Case "B80" To "B84": Fn_Year = "1998"
        Case "B90" To "B94": Fn_Year = "1999"
        Case "B94":          Fn_Year = "1994"
        Case "B95":          Fn_Year = "1995"
        Case "B96":          Fn_Year = "1996"
        Case "B97":          Fn_Year = "1997"
        Case "B98":          Fn_Year = "1998"
        Case "B99":          Fn_Year = "1999"
        Case "H87":          Fn_Year = "1987"
        Case "H88":          Fn_Year = "1988"
        Case "P89":          Fn_Year = "1989"
        Case "P90":          Fn_Year = "1990"
        Case "P91":          Fn_Year = "1991"
        Case "P92":          Fn_Year = "1992"
        Case "T89":          Fn_Year = "1989"
        Case "T90":          Fn_Year = "1990"
        Case "T91":          Fn_Year = "1991"
        Case "T92":          Fn_Year = "1992"
        Case "S90":          Fn_Year = "1990"
        Case "A15":          Fn_Year = "1995"
        Case "A15":          Fn_Year = "1995"
        Case "C15":          Fn_Year = "1995"
        Case "D15":          Fn_Year = "1995"
        Case "E15":          Fn_Year = "1995"
        Case "L15":          Fn_Year = "1995"
        Case "G15":          Fn_Year = "1995"
        Case "H15":          Fn_Year = "1995"
        Case "I15":          Fn_Year = "1995"
        Case "Y15":          Fn_Year = "1995"
        Case "870":          Fn_Year = "1987"
        Case "880" To "883": Fn_Year = "1988"
        Case "DC3":          Fn_Year = "2003"
        Case Else:           Fn_Year = "????"
'            If LOCCS_Rec(7) <> "1/1/100" Then
'                Fn_Year = Str(Year(LOCCS_Rec(7))) 'Use Eff_date -1
'            End If
'            'Debug.Print LOCCS_Rec(0), Fn_Year, LOCCS_Rec(7)
    End Select
ElseIf Program = "SPC" Then
    Select Case stYYY
        Case "C00" To "C02": Fn_Year = "2000"
        Case "C10" To "C12": Fn_Year = "2001"
        Case "C20" To "C22": Fn_Year = "2002"
        Case "C30" To "C32": Fn_Year = "2003"
        Case "C40" To "C42": Fn_Year = "2004"
        Case "C50" To "C52": Fn_Year = "2005"
        Case "C60" To "C62": Fn_Year = "2006"
        Case "C70" To "C72": Fn_Year = "2007"   ':090503 Fix for 2007 Program Year
        'Case "2008":         Fn_Year = "2008"  '????
        'Case "2009":         Fn_Year = "2009"
        'Case "2010":         Fn_Year = "2010"
        'Case "2011":         Fn_Year = "2011"
        Case "C80" To "C82": Fn_Year = "1998"
        Case "C92":          Fn_Year = "1992"
        Case "C93":          Fn_Year = "1993"
        Case "C94":          Fn_Year = "1994"
        Case "C95":          Fn_Year = "1995"
        Case "C96":          Fn_Year = "1996"
        Case "C97":          Fn_Year = "1997"
        Case "C98":          Fn_Year = "1998"
        Case "C90" To "C91": Fn_Year = "1999"
        Case "DC3":          Fn_Year = "2003"
        Case Else
            Fn_Year = Str(Year(LOCCS_Rec(7))) 'Use Eff_date -1
            'Debug.Print LOCCS_Rec(0), Fn_Year, LOCCS_Rec(10)
    End Select
End If
ExitFunction:
End Function
Function Fn_CoCYear(Project As String)
Dim stYYY As String
stYYY = Mid(Project, 5, 3)
 
    Select Case stYYY
        Case "B00" To "B04": Fn_CoCYear = "2000"
        Case "B10" To "B14": Fn_CoCYear = "2001"
        Case "B20" To "B24": Fn_CoCYear = "2002"
        Case "B30" To "B34": Fn_CoCYear = "2003"
        Case "B40" To "B44": Fn_CoCYear = "2004"
        Case "B50" To "B54": Fn_CoCYear = "2005"
        Case "B60" To "B64": Fn_CoCYear = "2006"
        Case "B80" To "B84": Fn_CoCYear = "1998"
        Case "B90" To "B94": Fn_CoCYear = "1999"
        Case "B94":          Fn_CoCYear = "1994"
        Case "B95":          Fn_CoCYear = "1995"
        Case "B96":          Fn_CoCYear = "1996"
        Case "B97":          Fn_CoCYear = "1997"
        Case "B98":          Fn_CoCYear = "1998"
        Case "B99":          Fn_CoCYear = "1999"
        Case "C00" To "C02": Fn_CoCYear = "2000"
        Case "C10" To "C12": Fn_CoCYear = "2001"
        Case "C20" To "C22": Fn_CoCYear = "2002"
        Case "C30" To "C32": Fn_CoCYear = "2003"
        Case "C40" To "C42": Fn_CoCYear = "2004"
        Case "C50" To "C52": Fn_CoCYear = "2005"
        Case "C60" To "C62": Fn_CoCYear = "2006"
        Case "C80" To "C82": Fn_CoCYear = "1998"
        Case "C92":          Fn_CoCYear = "1992"
        Case "C93":          Fn_CoCYear = "1993"
        Case "C94":          Fn_CoCYear = "1994"
        Case "C95":          Fn_CoCYear = "1995"
        Case "C96":          Fn_CoCYear = "1996"
        Case "C97":          Fn_CoCYear = "1997"
        Case "C98":          Fn_CoCYear = "1998"
        Case "C90" To "C91": Fn_CoCYear = "1999"
        Case Else: Fn_CoCYear = "????"
    End Select
End Function
Function Fn_YearNew(stRetstring As String) As String
'--------------------------------------------------
'Execute for Grant Numbers with 15 or more digits (2008 & later)
'--------------------------------------------------
    Dim iFundYr As Integer
    Dim iNewRenew As Integer
    '---------------------------------------------
    'stRetstring = "MA0001B1T000801"    'DEBUG ONLY
    '----------------------------------------------
    iFundYr = CStr(Mid(stRetstring, 12, 2))
    iNewRenew = CInt(Mid(stRetstring, 14, 2))
    If iNewRenew = 0 Then
        Fn_YearNew = CStr(2000 + iFundYr)
    Else
        Fn_YearNew = CStr(2000 + iFundYr + iNewRenew - 1)
    End If
End Function
Function Fn_State(Retstring As String) As String
    Dim State As String
    State = Trim(Mid(Retstring, 1, 1))         'State
 
    If Program = "YB" Then
        Fn_State = Trim(Mid(Retstring, 6, 2))         'State
    ElseIf Trim(Mid(Retstring, 1, 2)) = "H9" Then
        Fn_State = "??"         'State
    Else
        Fn_State = Trim(Mid(Retstring, 1, 2))
    End If
End Function
Function Fn_Term(Retstring As String, Pass As Integer)
'----------------------------------------------------------------------------------------
'This function is used twice for each record processed.  The first pass is for
'processing the raw grant line which has a valid term only for SHP grants and a
'36 month estimate for YB and HOPWAC grants. The second pass is for processing
'the final LOCCS record where the term must be estimated for SPC grants only.
'----------------------------------------------------------------------------------------
Dim Grant As String, GrantYear As String, Priority As String
Dim ElapsedDays As Variant, ElapsedMonths As Variant, M12 As Variant, M60 As Variant
Dim PctGrantSpent As Variant, AbsM12 As Variant, AbsM60, PctSpent As Variant
Dim Term As Single
Dim Activity As String
Dim StartDate As Date
Dim ReportDate As Date
Dim Authorized As Currency
Dim Disbursed As Currency
Dim Balance As Currency
Dim DaysExpired As Single
Dim PctTermExp As Single
Dim PctAwardSpent As Single
Dim Acq_NC_REH  As String
Dim BLICodes As String
Grant = LOCCS_Rec(0)
GrantYear = LOCCS_Rec(2)
Priority = Right(Grant, 2)
Program = LOCCS_Rec(4)
Activity = LOCCS_Rec(12)
Authorized = CCur(LOCCS_Rec(13))
Disbursed = CCur(LOCCS_Rec(14))
Balance = CCur(LOCCS_Rec(15))
ReportDate = CDate(LOCCS_Rec(16))
BLICodes = LOCCS_Rec(17)
PctTermExp = LOCCS_Rec(18)
PctAwardSpent = LOCCS_Rec(19)
If Pass = 1 Then
    If Program = "HPAC" Then
        Fn_Term = "36"
    ElseIf Program = "SHP" Then
        Fn_Term = Trim(Mid(Retstring, 129, 4))
    ElseIf Program = "YB" Then
        Fn_Term = "36"
    End If
End If
 
If Pass = 2 And Program <> "SPC" Then
    Fn_Term = LOCCS_Rec(9)                  'Only SPC records will be changed
ElseIf Pass = 2 And Program = "SPC" Then
    Fn_Term = "No Data"        'Edit 061405
'    StartDate = CDate(LOCCS_Rec(7))
'    ElapsedDays = DateDiff("d", StartDate, ReportDate)
'    ElapsedMonths = DateDiff("m", StartDate, ReportDate)
'    M12 = ElapsedMonths / 12
'    M60 = ElapsedMonths / 60
'    AbsM12 = Abs(PctGrantSpent - M12)
'    AbsM60 = Abs(PctGrantSpent - M60)
'    If Authorized > 0 Then
'        PctSpent = Disbursed / Authorized
'    End If
'    If StartDate < #1/1/1999# Then    ' OLD GRANT - ASSUME A FIVE YEAR TERM.
'        Fn_Term = "60"
'    ElseIf (ElapsedMonths < 12) And (PctSpent > 0.25) Then  'Spent 25% of Grant in less than one year - RENEWAL
'        Fn_Term = "12"
'    ElseIf (StartDate > #1/1/1999#) And (Priority = "01") Then  'Grant Priority of 1 after 2000 is a NEW FIVE YEAR GRANT
'        Fn_Term = "60"
'    ElseIf (StartDate > #1/1/1999#) And (Priority > "05") Then  'Low Grant PRIORITY is most likely a RENEWAL
'        Fn_Term = "12"
'    ElseIf (Authorized = 0) And (Disbursed > 0) Then    'Multiple grants funded by one master grant - TERM UNKNOWN
'        Fn_Term = "00"
'    ElseIf Authorized = 0 Then
'       Fn_Term = "00"
'    ElseIf (ElapsedMonths > 24) And (PctSpent > 0.6) Then
'        Fn_Term = "60"
'    ElseIf (Authorized = 0) And (Disbursed > 0) Then
'        Fn_Term = "0"
'    ElseIf (ElapsedMonths <= 18) And (Disbursed > 0) And (AbsM12 > AbsM60) Then
'        Fn_Term = "12"
'    ElseIf (ElapsedMonths <= 18) And (Disbursed > 0) And (AbsM12 < AbsM60) Then
'        Fn_Term = "60"
'    ElseIf (ElapsedMonths >= 18) And (ElapsedMonths < 64) And (Disbursed > 0) Then
'        Fn_Term = "60"
'    End If
End If
'If (Program = "SPC") And (Pass = 2) And (Fn_Term <> "0") Then
    'Debug.Print Grant, Round(PctGrantSpent, 2), StartDate, ElapsedMonths, Fn_Term, Authorized, Disbursed, Balance
'End If
End Function
Function Fn_CoCPgm(Pgm As String) As String
If Pgm = "SHPR" Or Pgm = "SHP" Or Pgm = "SH/T" Or Pgm = "SH/P" Then
    Fn_CoCPgm = "SHP"
ElseIf Pgm = "SPC" Or Pgm = "SPCR" Then
    Fn_CoCPgm = "SPC"
End If
 
 
End Function
Function Fn_PrtHdr()
'----------------------------------------------------------------
'11/20/05-BOSSNAPSplus 100405a: Setup for new CoC Overview Report
'----------------------------------------------------------------
Dim i As Integer
Dim Balance As Variant
Dim Rpt_Hdr As String
Dim FieldNames(FieldNamesCnt)
'--------------------------------------
'The A67 LOCCS fields (23) are listed below. Note that if there is a matching
'CoC record then several CoC fields are copied up to
FieldNames(0) = "LOCCS_Nmbr"        'LOCCS_Rec(0)= LOCCS_Nmbr/CoCField_19
FieldNames(1) = "LOCCS_Nmbr1"       'LOCCS_Rec(1)= LOCCS_Nmbr1
FieldNames(2) = "YEAR"              'LOCCS_Rec(2)= YEAR/CoCField_17
FieldNames(3) = "STATE"             'LOCCS_Rec3/CoCField_15
FieldNames(4) = "Program"           'LOCCS_Rec(4)/CoCField_5
FieldNames(5) = "Grantee_Nm"        'LOCCS_Rec(5)
FieldNames(6) = "Grantee_TID"       'LOCCS_Rec(6)
FieldNames(7) = "EFF_DATE"          'LOCCS_Rec(7)
FieldNames(8) = "Start_Date"        'LOCCS_Rec(8)
FieldNames(9) = "Term_months"       'LOCCS_Rec(9)/CoCField_6
FieldNames(10) = "Exp_Date"         'LOCCS_Rec(10)
FieldNames(11) = "MonthsElapsed"    'LOCCS_Rec(11)
FieldNames(12) = "Activity"         'LOCCS_Rec(12)
FieldNames(13) = "Authorized"       'LOCCS_Rec(13)/CoCField_12
FieldNames(14) = "Disbursed"        'LOCCS_Rec(14)
FieldNames(15) = "Balance"          'LOCCS_Rec(6)/CoCField_12
FieldNames(16) = "LOCC_RptDate"     'LOCCS_Rec(17)
FieldNames(17) = "BLI_Codes"        'LOCCS_Rec(18)
FieldNames(18) = "%TermExpired"     'LOCCS_Rec(19)
FieldNames(19) = "%AwardSpent"      'LOCCS_Rec(20)
FieldNames(20) = "SlowSpender"      'LOCCS_Rec(21)
FieldNames(21) = "Covenant"         'LOCCS_Rec(22)
FieldNames(22) = "ActiveGrant"      'LOCCS_Rec(23)
'--------------------------------------------
'The unique CoC fields (15) are listed below
'--------------------------------------------
FieldNames(23) = "COC_Code"         'CoCField_14
FieldNames(24) = "PIN"              'CoCField_1
FieldNames(25) = "CoCPgmCode"       'CoCField_5
FieldNames(26) = "CoCComponet"      'CoCField_7
FieldNames(27) = "CoCTerm"          'CoCField_6
FieldNames(28) = "COCApplicant"     'CoCField_8
FieldNames(29) = "CoCSponsor"       'CoCField_9
FieldNames(30) = "CoCProjectName"   'CoCField_10
FieldNames(31) = "CoCAward"         'CoCField_12
FieldNames(32) = "CoCContName"      'CoCField_16
FieldNames(33) = "Status"           'CoCField_20
FieldNames(34) = "Rep"              'CoCField_13
FieldNames(35) = "User1"            'CoCField_21
FieldNames(36) = "User2"            'CoCField_22
FieldNames(37) = "User3 "           'CoCField_23
'---------------------------------------------------------------
'The financial Budget Line Items (BLI) fields.
'There are 30 Budget categories with 3 entries for each category-
'Award, Expenditures and Balance for a total of 90 BLI fields
'for each grant are listed below
'Total fields for an A67 record is 24 + 14+ 90 = 128
'---------------------------------------------------------------
FieldNames(38) = "A_SRA"            'BLICodes(2,0)
FieldNames(39) = "D_SRA"            'BLICodes(3,0)
FieldNames(40) = "B_SRA"            'BLICodes(4,0)
FieldNames(41) = "A_ACQ"            'BLICodes(2,1)
FieldNames(42) = "D_ACQ"            'BLICodes(3,1)
FieldNames(43) = "B_ACQ"            'BLICodes(4,1)
FieldNames(44) = "A_REH"            'BLICodes(2,2)
FieldNames(45) = "D_REH"            'BLICodes(3,2)
FieldNames(46) = "B_REH"            'BLICodes(4,2)
FieldNames(47) = "A_NC"             'BLICodes(2,3)
FieldNames(48) = "D_NC"             'BLICodes(3,3)
FieldNames(49) = "B_NC"             'BLICodes(4,3)
FieldNames(50) = "A_SREH"           'BLICodes(2,4)
FieldNames(51) = "D_SREH"           'BLICodes(3,4)
FieldNames(52) = "B_SREH"           'BLICodes(4,4)
FieldNames(53) = "A_MREH"           'BLICodes(2,5)
FieldNames(54) = "D_MREH"           'BLICodes(3,5)
FieldNames(55) = "B_MREH"           'BLICodes(4,5)
FieldNames(56) = "A_OPER"           'BLICodes(2,6)
FieldNames(57) = "D_OPER"           'BLICodes(3,6)
FieldNames(58) = "B_OPER"           'BLICodes(4,6)
FieldNames(59) = "A_RA"             'BLICodes(2,7)
FieldNames(60) = "D_RA"             'BLICodes(3,7)
FieldNames(61) = "B_RA"             'BLICodes(4,7)
FieldNames(62) = "A_SS"             'BLICodes(2,8)
FieldNames(63) = "D_SS"             'BLICodes(3,8)
FieldNames(64) = "B_SS"             'BLICodes(4,8)
FieldNames(65) = "A_HMIS"           'BLICodes(2,9)
FieldNames(66) = "D_HMIS"           'BLICodes(3,9)
FieldNames(67) = "B_HMIS"           'BLICodes(4,9)
FieldNames(68) = "A_ADMIN"          'BLICodes(2,10)
FieldNames(69) = "D_ADMIN"          'BLICodes(3,10)
FieldNames(70) = "B_ADMIN"          'BLICodes(4,10)
FieldNames(71) = "A_CCARE"          'BLICodes(2,11)
FieldNames(72) = "D_CCARE"          'BLICodes(3,11)
FieldNames(73) = "B_CCARE"          'BLICodes(4,11)
FieldNames(74) = "A_EMPAS"          'BLICodes(2,12)
FieldNames(75) = "D_EMPAS"          'BLICodes(3,12)
FieldNames(76) = "B_EMPAS"          'BLICodes(4,12)
FieldNames(77) = "A_RELOC"          'BLICodes(2,13)
FieldNames(78) = "D_RELOC"          'BLICodes(3,13)
FieldNames(79) = "B_RELOC"          'BLICodes(4,13)
FieldNames(80) = "A_LEASE"          'BLICodes(2,14)
FieldNames(81) = "D_LEASE"          'BLICodes(3,14)
FieldNames(82) = "B_LEASE"          'BLICodes(4,14)
FieldNames(83) = "A_REPMAN"         'BLICodes(2,15)
FieldNames(84) = "D_REPMAN"         'BLICodes(3,15)
FieldNames(85) = "B_REPMAN"         'BLICodes(4,15)
FieldNames(86) = "A_PREV"           'BLICodes(2,16)
FieldNames(87) = "D_PREV"           'BLICodes(3,16)
FieldNames(88) = "B_PREV"           'BLICodes(4,16)
FieldNames(89) = "A_CAPBLD"         'BLICodes(2,17)
FieldNames(90) = "D_CAPBLD"         'BLICodes(3,17)
FieldNames(91) = "B_CAPBLD"         'BLICodes(4,17)
FieldNames(92) = "A_OTHER"          'BLICodes(2,18)
FieldNames(93) = "D_OTHER"          'BLICodes(3,18)
FieldNames(94) = "B_OTHER"          'BLICodes(4,18)
FieldNames(95) = "A_FOH"            'BLICodes(2,19)
FieldNames(96) = "D_FOH"            'BLICodes(3,19)
FieldNames(97) = "B_FOH"            'BLICodes(4,19)
FieldNames(98) = "A_TRA"            'BLICodes(2,20)
FieldNames(99) = "D_TRA"            'BLICodes(3,20)
FieldNames(100) = "B_TRA"            'BLICodes(4,20)
FieldNames(101) = "A_OUTR"           'BLICodes(2,21)
FieldNames(102) = "D_OUTR"           'BLICodes(3,21)
FieldNames(103) = "B_OUTR"           'BLICodes(4,21)
FieldNames(104) = "A_EDUC"          'BLICodes(2,22)
FieldNames(105) = "D_EDUC"          'BLICodes(3,22)
FieldNames(106) = "B_EDUC"          'BLICodes(4,22)
FieldNames(107) = "A_STIPEND"       'BLICodes(2,23)
FieldNames(108) = "D_STIPEND"       'BLICodes(3,23)
FieldNames(109) = "B_STIPEND"       'BLICodes(4,23)
FieldNames(110) = "A_COUNSEL"       'BLICodes(2,24)
FieldNames(111) = "D_COUNSEL"       'BLICodes(3,24)
FieldNames(112) = "B_COUNSEL"       'BLICodes(4,24)
FieldNames(113) = "A_TA"            'BLICodes(2,25)
FieldNames(114) = "D_TA"            'BLICodes(3,25)
FieldNames(115) = "B_TA"            'BLICodes(4,25)
FieldNames(116) = "A_JOBPLAC"       'BLICodes(2,26)
FieldNames(117) = "D_JOBPLAC"       'BLICodes(3,26)
FieldNames(118) = "B_JOBPLAC"       'BLICodes(4,26)
FieldNames(119) = "A_YBADMIN"       'BLICodes(2,27)
FieldNames(120) = "D_YBADMIN"       'BLICodes(3,27)
FieldNames(121) = "B_YBADMIN"       'BLICodes(4,27)
FieldNames(122) = "A_PRAW"          'BLICodes(2,28)
FieldNames(123) = "D_PRAW"          'BLICodes(3,28)
FieldNames(124) = "B_PRAW"          'BLICodes(4,28)
FieldNames(125) = "A_PRA"           'BLICodes(2,29)
FieldNames(126) = "D_PRA"           'BLICodes(3,29)
FieldNames(127) = "B_PRA"           'BLICodes(4,29)
 
 
 
Rpt_Hdr = ""
For i = 0 To FieldNamesCnt
Rpt_Hdr = Rpt_Hdr + FieldNames(i) + Chr(9)
Next i
Fn_PrtHdr = Rpt_Hdr
End Function
Function Fn_MonthsElapsed() As Long
 
    'Public dtDepconDate As Date
    Dim EffDate As Date, ReportDate As Date
    Dim StartDate As Date
    Dim Balance As Variant
    EffDate = CDate(LOCCS_Rec(7))
    StartDate = CDate(LOCCS_Rec(8))
 
 
 
    If Program = "SPC" Or Program = "YB" Or Program = "HPAC" Then
        If EffDate = #1/1/100# Then
            Fn_MonthsElapsed = 0
        Else
            Fn_MonthsElapsed = DateDiff("m", EffDate, dtDepconDate)
        End If
    ElseIf Program = "SHP" Then
        If StartDate = #1/1/100# Then
            Fn_MonthsElapsed = 0
        Else
            Fn_MonthsElapsed = DateDiff("m", StartDate, dtDepconDate)
        End If
    End If
    End Function
Function Fn_RecordOut() As String
 
Dim RecordOut As String
Dim i As Integer
RecordOut = ""
For i = 0 To LOCCSFldCnt
    RecordOut = RecordOut + LOCCS_Rec(i) + Chr(9)
Next i
For i = 0 To CoC_RecCnt 'Rev:-112505 Update (removed -1)
    RecordOut = RecordOut + CoC_Rec(i) + Chr(9)
Next i
For i = 0 To BLIFldCnt
    RecordOut = RecordOut + BLICodes(2, i) + Chr(9) + BLICodes(3, i) + Chr(9) + BLICodes(4, i) + Chr(9)
Next i
Fn_RecordOut = RecordOut
End Function
Function Fn_PctAwardSpent(Authorized As Currency, Disbursed As Currency) As Single
If Authorized = 0 Then
    Fn_PctAwardSpent = 0
Else
    Fn_PctAwardSpent = Disbursed / Authorized
End If
End Function
Function Fn_RestCov() As String
Dim BLICode As String
BLICode = LOCCS_Rec(17)
If (InStr(1, BLICode, ",NC")) > 0 Then
    Fn_RestCov = "True"
ElseIf (InStr(1, BLICode, ",ACQ")) > 0 Then
    Fn_RestCov = "True"
ElseIf (InStr(1, BLICode, "REH")) > 0 Then
    Fn_RestCov = "True"
ElseIf (InStr(1, BLICode, "PRAW")) > 0 Then
    Fn_RestCov = "True"
End If
End Function
Function Fn_COCID(Pgm) As String
Dim Project As String, State As String
Dim EffDate As Date
Dim VID As Boolean
Dim C5 As String, C56 As String, C6 As String, C67 As String, C78 As String, C89 As String
Project = LOCCS_Rec(0)
EffDate = CDate(LOCCS_Rec(7))
If (EffDate > #1/1/1998#) Then
    VID = True
Else
    VID = False
End If
State = LOCCS_Rec(3)
C5 = Mid(Project, 5, 1)
C56 = Mid(Project, 5, 2)
C6 = Mid(Project, 6, 1)
C67 = Mid(Project, 6, 2)
C78 = Mid(Project, 7, 2)
C89 = Mid(Project, 8, 2)
If Pgm = "SHP" Then
    If (C5 = "B") And (C6 < "7") And (VID = True) Then
        Fn_COCID = State + C78
    ElseIf (C67 > "91") Then
        Fn_COCID = State + C89
    ElseIf (C6 = "9") Then
        Fn_COCID = State + C78
    ElseIf (C56 = "B8") Then
        Fn_COCID = State + C78
   End If
'----------------------------------------------------
ElseIf Pgm = "SPC" Then
    If (C6 < "7") Then
        Fn_COCID = State + C78
    ElseIf (C67 > "91") Then
        Fn_COCID = State + C89
    ElseIf (C6 = "9") Then
        Fn_COCID = State + C78
    End If
'----------------------------------------------------
ElseIf Pgm = "HPAC" Then
End If
End Function
Function Fn_ActiveGrant() As String
    Dim Fn_Pgm  As String, PgmYr As String
    Dim StartDate As Date, EffectiveDate As String, DaysExpired As String
    Dim Balance As Variant, Authorized As Variant, PctSpent As Variant, PctExp As Variant
 
Fn_Pgm = LOCCS_Rec(4)
PgmYr = LOCCS_Rec(3)
StartDate = CDate(LOCCS_Rec(8))
EffectiveDate = CDate(LOCCS_Rec(7))
'MonthsElapsed = (LOCCS_Rec(11))
Balance = CDec(LOCCS_Rec(15))
Authorized = CDec(LOCCS_Rec(13))
PctSpent = LOCCS_Rec(19)
PctExp = LOCCS_Rec(18)
 
If Balance > 0 Then
    Fn_ActiveGrant = "True"
ElseIf (Authorized = 0) And (Balance = 0) Then
    Fn_ActiveGrant = "True"
Else
    Fn_ActiveGrant = "False"
End If
End Function
Function Fn_NmTest(WorS As String, Name As String) As String
Dim w As Variant
Dim WrkbkName As String, Sheetname As String
 
If WorS = "W" Then
    For Each w In Workbooks
        WrkbkName = w.Name
        If (InStr(1, WrkbkName, Name)) > 0 Then
            Workbooks(WrkbkName).Activate
            Exit For
        End If
    Next w
    If Mid(WrkbkName, 1, 9) <> "LOCCSRpt_" Then
        MsgBox ("You must first run the 'Convert LOCCS Reports to a Database' Macro" + Chr(13) _
        + "or open an existing 'LOCCSRpt_mm.dd.yy.xls' file")
        Fn_NmTest = "False"
    Else
        Fn_NmTest = "True"
    End If
 
ElseIf WorS = "S" Then
    For Each w In Sheets
       Sheetname = w.Name
        If (InStr(1, Sheetname, Name)) > 0 Then
            Sheets(Name).Activate
            Exit For
        End If
    Next w
    If Mid(Sheetname, 1, 9) <> Name Then
        Fn_NmTest = "False"
    Else
        Fn_NmTest = "True"
    End If
End If
End Function
Function Fn_DateCleanup(stGrantLine As String, LOCCSIndex As Integer) As String
 
    Dim DateIn As String
 
    If LOCCSIndex = 7 Then
        DateIn = Trim(Mid(stGrantLine, 79, 10))       'Eff_Date
    ElseIf LOCCSIndex = 8 Then
        DateIn = Trim(Mid(stGrantLine, 104, 10))      'Start_Date
    End If
    If (DateIn = "00/00/0000") Or (DateIn = "01/01/00") Then
        Fn_DateCleanup = "1/1/100"
    ElseIf (DateIn = "/  /") Or (DateIn = "/ /") Or (DateIn = "") Then
        Fn_DateCleanup = "1/1/100"
    Else
        Fn_DateCleanup = DateIn
    End If
End Function
Function Fn_PctTermExp() As Single
 
Dim Program As String, Term As String
Dim ReportDate As Date
Dim StartDate As Date
Dim ExpDate As Date
Dim DaysExpired As Single
Dim TermDays As Single
Program = LOCCS_Rec(4)
If Program = "SPC" Then Exit Function   'Edit 061405
If Program = "SHP" Then
    StartDate = LOCCS_Rec(8)
Else
    StartDate = LOCCS_Rec(7)
End If
ReportDate = LOCCS_Rec(16)
ExpDate = LOCCS_Rec(10)
Term = LOCCS_Rec(9)
If Program = "SHP" Then
    If ExpDate = #1/1/100# Then
        'Do not calculate days expired for grants with a balance of zero
    Else
        DaysExpired = DateDiff("d", StartDate, ReportDate)
        TermDays = DateDiff("d", StartDate, ExpDate)
        Fn_PctTermExp = DaysExpired / TermDays
    End If
Else
    DaysExpired = DateDiff("d", StartDate, ReportDate)
    TermDays = DateDiff("d", StartDate, ExpDate)
    Fn_PctTermExp = DaysExpired / TermDays
End If
End Function
Function Fn_FileExists(FullPathName As String) As Boolean
 
    Dim fs As Variant
 
    Set fs = CreateObject("Scripting.FileSystemObject")
    If (fs.FileExists(FullPathName)) Then Fn_FileExists = True
End Function
 
Sub DepconSetup()   'Fix:090301 to replace "Application.Filesearch"
'------------------------------------------------------------------------------------------
'This subroutine will read all CPD A67B2cc reports in J:\DEPCON and identify each file as
' SHP,SPC,YB,HPAC.  Note that there are 2 or 3 files for each category.
'------------------------------------------------------------------------------------------
    Const ForReading = 1, ForAppending = 8
    Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
 
    'Public stDepConFileNm As String    'The DepCon File Name to be saved
    'Public stDepconFullNm As String       'Full Depcon File name to be saved
    'Public stDepconDatex As String     'The string date with "/" delimiter of the newest Depcon monthly group
    'Public stDepconDate As String      'The string date without "/" delimiter of the newest Depcon monthly group
    'Public LocFiles(3, 125) As String
        'LocFiles(0,n)- A valid DEPCON CPD report name (i.e. string "A67B2CC" in line #1)
        'LocFiles(1,n)- The Program Type Code SNAP,SPC,YB, etc
        'LocFiles(2,n)- The date of the report
        'LocFiles(3,n)- The HUD Office Name
 
 
    Dim i As Long
    Dim icount As Long
    Dim j As Long
    Dim k As Long
    Dim tsin As Variant
    Dim fs As Variant
    Dim fs1 As Variant
    Dim f As Variant
    Dim f1 As Variant
    Dim fc As Variant
    Dim vafilename As Variant
    Dim dtFileDate As Date
    Dim dtNewestDate As Date
    Dim stNewestDate As String
    Dim blDepConDir As Boolean
    Dim stOffice As String
    Dim Retstring As String
    Dim stA67Date As String
    Dim Pgm As String
    Dim stA67RptNm As String
    Dim Msg1 As String
    Dim iEOLPtr As Integer
    Dim iA67Cnt As Integer
    Dim t As Single
    Dim stFileSearch As String
    Dim s As String
    Dim stMacroDir As String
    Dim vaArray As Variant
 
    t = Timer
 
    stMacroDir = ThisWorkbook.Path
    'stDEPCONDir = "C:\Documents and Settings\Richard\My Documents\BOSSNAPS\DEPCON"    '-----------DEBUG ONLY ----------------
    Set fs1 = CreateObject("Scripting.FileSystemObject")
'-------------------------------------------------------------------
'If there is no J:\DEPCON Folder then exit Subroutine with null date
'-------------------------------------------------------------------
    blDepConDir = fs1.folderexists(stDEPCONDir)
    If blDepConDir = False Then
    dtDepconDate = #1/1/100#        'Return Error Date if no J:\DEPCON files
        Exit Sub
    End If
 '-------------------------------------------------------------------
 'Find all the CPD Depcon reports using Application.FileSearch Method
 'Populate the LocFiles(3,125) Array with Filename, Pgm, FileDate, Office Name
 '-------------------------------------------------------------------
 
    stFileSearch = "*.BKP"
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(stDEPCONDir)
    Set fc = f.Files    'Create a list object of all files in BOSSNAPS+ Directory
    ReDim vaArray(1)                            '------Clear the PRArray dimensions-----
 
    For Each f1 In fc                           'Test each file in list
        s = f1.Name                             'Get the filename
        If (s Like stFileSearch) Then
            s = stDEPCONDir & "\" & s     'Create a full pathname to be compatible with original code
            icount = icount + 1
            ReDim Preserve vaArray(icount)
            vaArray(icount) = s
        End If
    Next
'-------------------------------------------------------------------
'If there are no reports in the J:\DEPCON Folder then exit Subroutine with null date
'-------------------------------------------------------------------
    If icount = 0 Then
        dtDepconDate = #1/1/100#        'Return Error Date if no J:\DEPCON files
        Exit Sub                        'EXIT SUB
    Else
        blDepConFiles = True
    End If
'--------------------------------------------------------------------------
'There are Depcon reports. Populate LocFiles() array with Depcon file info
'--------------------------------------------------------------------------
    k = 0
    For i = 1 To UBound(vaArray)
        Set f = fs1.getfile(vaArray(i))
        dtFileDate = f.datelastmodified
         'If Now < DateAdd("m", 3, dtFileDate) Then
            Set tsin = fs1.OpenTextFile(vaArray(i), ForReading, TristateFalse)
            Pgm = ""
            j = 1
            Do While tsin.AtEndOfStream <> True
                Retstring = tsin.ReadLine
                If Mid(Retstring, 1, 3) = "BVB" Then Retstring = tsin.ReadLine  'FIX:090301 for bad line 1
                'Debug.Print VaFilename, retstring
                If (InStr(Retstring, "STATUS OF FUNDS") > 20) Then
                    Pgm = Trim(Mid(Trim(Retstring), 1, 6))
                        Exit Do
                ElseIf (j = j + 1) > 10 Then
                    Exit Do
                End If
                j = j + 1
            Loop
            If (Pgm = "SNAP") Or (Pgm = "SPC") Or (Pgm = "SPCR") Or (Pgm = "HPAC") _
                Or (Pgm = "YB") Then
                stA67RptNm = vaArray(i)
                LocFiles(0, k) = stA67RptNm
                LocFiles(1, k) = Pgm
                LocFiles(2, k) = Mid(Trim(tsin.ReadLine), 7) 'Date of Depcon A67 File
                Retstring = tsin.ReadLine   'Bypass the "Region:" Line
                LocFiles(3, k) = stCPDOffice    '06/27/05 Force the file to National File Name
                tsin.Close
                'Debug.Print k, LocFiles(0, k), LocFiles(1, k), LocFiles(2, k), LocFiles(3, k)
                k = k + 1
            End If
        Next i
    iA67Cnt = k - 1
'-------------------------------------------------------------------------
' If there are no valid CPD (A67B2CC) reports print error message and exit
'-------------------------------------------------------------------------
    If iA67Cnt < 1 Then
        dtDepconDate = #1/1/100#        'Return Error Date if no J:\DEPCON files
        blDepConFiles = False
        Exit Sub
    End If
    dtNewestDate = #1/1/100#
    For i = 1 To iA67Cnt
        dtFileDate = CDate(LocFiles(2, i))
        If dtFileDate > dtNewestDate Then
            dtNewestDate = dtFileDate
            stDepconDatex = LocFiles(2, i)          'Rev-082605E
            dtRptDate = CVDate(stDepconDatex)
            stA67Date = Replace(LocFiles(2, i), "/", "")
            stOffice = LocFiles(3, i)
            stOffice = Replace(stOffice, "/", "-")
            stDepConFileNm = "A67R1." & stOffice & "." & stA67Date
        End If
    Next i
    'Debug.Print 1.1; dtNewestDate, stDepconDate, stDepconDatex, stDepconFullNm
    stDepconFullNm = stMacroDir & "\" & stDepConFileNm
    stDepconDate = stA67Date    'Set Public Variable for string date of DEPCON Report grp
    dtDepconDate = dtNewestDate 'Set Public Variable to date of newest DEPCON Report group
     Debug.Print "    DepconSetup", Format((Timer - t), "#0.#00"), dtDepconDate; icount
End Sub
Sub DepconSetupoRIG()   'Original version on 090301 before updates
'------------------------------------------------------------------------------------------
'This subroutine will read all CPD A67B2cc reports in J:\DEPCON and identify each file as
' SHP,SPC,YB,HPAC.  Note that there are 2 or 3 files for each category.
'------------------------------------------------------------------------------------------
    Const ForReading = 1, ForAppending = 8
    Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
 
    'Public stDepConFileNm As String    'The DepCon File Name to be saved
    'Public stDepconFullNm As String       'Full Depcon File name to be saved
    'Public stDepconDatex As String     'The string date with "/" delimiter of the newest Depcon monthly group
    'Public stDepconDate As String      'The string date without "/" delimiter of the newest Depcon monthly group
    'Public LocFiles(3, 125) As String
        'LocFiles(0,n)- A valid DEPCON CPD report name (i.e. string "A67B2CC" in line #1)
        'LocFiles(1,n)- The Program Type Code SNAP,SPC,YB, etc
        'LocFiles(2,n)- The date of the report
        'LocFiles(3,n)- The HUD Office Name
 
 
    Dim i As Long, icount As Long, j As Long
    Dim fs As Office.FileSearch
    Dim tsin As Variant
    Dim fs1 As Variant
    Dim f As Variant
    Dim vafilename As Variant
    Dim dtFileDate As Date
    Dim dtNewestDate As Date
    Dim stNewestDate As String
    Dim blDepConDir As Boolean
    Dim stOffice As String
    Dim Retstring As String
    Dim stA67Date As String, Pgm As String, stA67RptNm As String
    Dim Msg1 As String
    Dim iEOLPtr As Integer, iA67Cnt As Integer
    Dim t As Single
 
    t = Timer
 
    'stDEPCONDir = "C:\C-Mystuff\Depcon"    '-----------DEBUG ONLY ----------------
    Set fs = Application.FileSearch
    Set fs1 = CreateObject("Scripting.FileSystemObject")
'-------------------------------------------------------------------
'If there is no J:\DEPCON Folder then exit Subroutine with null date
'-------------------------------------------------------------------
    blDepConDir = fs1.folderexists(stDEPCONDir)
    If blDepConDir = False Then
    dtDepconDate = #1/1/100#        'Return Error Date if no J:\DEPCON files
        Exit Sub
    End If
 '-------------------------------------------------------------------
 'Find all the CPD Depcon reports using Application.FileSearch Method
 'Populate the LocFiles(3,125) Array with Filename, Pgm, FileDate, Office Name
 '-------------------------------------------------------------------
    With fs
        .NewSearch
        .LookIn = stDEPCONDir
        .SearchSubFolders = False
        .Filetype = msoFileTypeAllFiles
        .Filename = "*.BKP"
        icount = .Execute
'-------------------------------------------------------------------
'If there are no reports in the J:\DEPCON Folder then exit Subroutine with null date
'-------------------------------------------------------------------
        If icount = 0 Then
        dtDepconDate = #1/1/100#        'Return Error Date if no J:\DEPCON files
            Exit Sub
        Else
            blDepConFiles = True
        End If
'--------------------------------------------------------------------------
'There are Depcon reports. Populate LocFiles() array with Depcon file info
'--------------------------------------------------------------------------
        i = 0
        For Each vafilename In .FoundFiles
            Set f = fs1.getfile(vafilename)
            dtFileDate = f.datelastmodified
             'If Now < DateAdd("m", 3, dtFileDate) Then
                Set tsin = fs1.OpenTextFile(vafilename, ForReading, TristateFalse)
                Pgm = ""
                j = 1
                Do While tsin.AtEndOfStream <> True
                    Retstring = tsin.ReadLine
                    'Debug.Print VaFilename, retstring
                    If (InStr(Retstring, "STATUS OF FUNDS") > 20) Then
                        Pgm = Trim(Mid(Trim(Retstring), 1, 6))
                            Exit Do
                    ElseIf (j = j + 1) > 10 Then
                        Exit Do
                    End If
                    j = j + 1
                Loop
                    If (Pgm = "SNAP") Or (Pgm = "SPC") Or (Pgm = "SPCR") Or (Pgm = "HPAC") _
                        Or (Pgm = "YB") Then
                        stA67RptNm = vafilename
                        LocFiles(0, i) = stA67RptNm
                        LocFiles(1, i) = Pgm
                        LocFiles(2, i) = Mid(Trim(tsin.ReadLine), 7) 'Date of Depcon A67 File
                        Retstring = tsin.ReadLine   'Bypass the "Region:" Line
                        LocFiles(3, i) = stCPDOffice    '06/27/05 Force the file to National File Name
                        tsin.Close
                        Debug.Print i, LocFiles(0, i), LocFiles(1, i), LocFiles(2, i), LocFiles(3, i)
                        i = i + 1
                    End If
            'End If
        Next vafilename
    End With
    iA67Cnt = i - 1
'-------------------------------------------------------------------------
' If there are no valid CPD (A67B2CC) reports print error message and exit
'-------------------------------------------------------------------------
    If iA67Cnt < 1 Then
 
        dtDepconDate = #1/1/100#        'Return Error Date if no J:\DEPCON files
        blDepConFiles = False
 
        Exit Sub
    End If
    dtNewestDate = #1/1/100#
    For i = 0 To iA67Cnt
        dtFileDate = CVDate(LocFiles(2, i))
        If dtFileDate > dtNewestDate Then
            dtNewestDate = dtFileDate
            stDepconDatex = LocFiles(2, i)          'Rev-082605E
            dtRptDate = CVDate(stDepconDatex)
            stA67Date = Replace(LocFiles(2, i), "/", "")
            stOffice = LocFiles(3, i)
            stOffice = Replace(stOffice, "/", "-")
            stDepConFileNm = "A67R1." & stOffice & "." & stA67Date
        End If
    Next i
    'Debug.Print 1.1; dtNewestDate, stDepconDate, stDepconDatex, stDepconFullNm
    stDepconFullNm = stMacroDir & "\" & stDepConFileNm
    stDepconDate = stA67Date    'Set Public Variable for string date of DEPCON Report grp
    dtDepconDate = dtNewestDate 'Set Public Variable to date of newest DEPCON Report group
    Debug.Print "    DepconSetup", Format((Timer - t), "#0.#00"), dtDepconDate; icount
End Sub
Function Fn_SlowSpender() As String
Dim Authorized As Currency
Dim Disbursed As Currency
Dim Balance As Currency
Dim MonthsExpired As Single
Dim PctTermExp As Single
Dim PctAwardSpent As Single
Dim Acq_NC_REH  As String
Dim BLICodes As String, Grant As String, Award As String
Grant = LOCCS_Rec(0)
Program = LOCCS_Rec(4)
Award = LOCCS_Rec(13)
'MonthsElapsed = LOCCS_Rec(11)
PctTermExp = LOCCS_Rec(18)
PctAwardSpent = LOCCS_Rec(19)
BLICodes = LOCCS_Rec(17)
If (InStr(1, BLICodes, ",NC")) > 0 Then
    Acq_NC_REH = "True"
ElseIf (InStr(1, BLICodes, ",ACQ")) > 0 Then
    Acq_NC_REH = "True"
ElseIf (InStr(1, BLICodes, ",REH")) > 0 Then
    Acq_NC_REH = "True"
Else
    Acq_NC_REH = "False"
End If
If Program = "SHP" Then
    If (PctAwardSpent > 0.97) Then
        Fn_SlowSpender = "False"
    ElseIf (Award = 0) Then
        Fn_SlowSpender = "False"
    ElseIf (PctTermExp < 1) And (PctTermExp - PctAwardSpent < 0.25) Then
        Fn_SlowSpender = "False"
    ElseIf (PctTermExp < 1) And (PctTermExp - PctAwardSpent > 0.25) Then
        Fn_SlowSpender = "True"
    ElseIf (Program = "SHP") And (PctTermExp > 1.5) And (PctAwardSpent < 0.75) Then
        Fn_SlowSpender = "True"
    ElseIf (Program = "SHP") And (PctTermExp > 1.5) And (PctAwardSpent > 0.75) Then
        Fn_SlowSpender = "False"
    ElseIf (PctTermExp > 0.2) And (PctAwardSpent = 0) Then
        Fn_SlowSpender = "True"
    ElseIf (PctTermExp < 1) And (Abs(PctTermExp - PctAwardSpent) > 0.25) And (Acq_NC_REH = "False") Then
        Fn_SlowSpender = "True"
    ElseIf (PctTermExp < 1) And (Abs(PctTermExp - PctAwardSpent) < 0.25) And (Acq_NC_REH = "False") Then
        Fn_SlowSpender = "False"
'    ElseIf (DaysExpired > 90) And (DaysExpired < 180) And (PctAwardSpent < 0.9) Then
'        Fn_SlowSpender = "True"
'    ElseIf (Award > 0) And (DaysExpired > 180) Then
'        Fn_SlowSpender = "True"
    End If
ElseIf Program = "SPC" Then  'Edit 062405
'    If (PctAwardSpent > 0.91) Or (Award = 0) Then
'        Fn_SlowSpender = "FALSE"
'    ElseIf (PctTermExp < 1) And (Abs(PctTermExp - PctAwardSpent) > 0.25) Then
'        Fn_SlowSpender = "True"
'   End If
    Fn_SlowSpender = ""
ElseIf Program = "YB" Then
    If (PctAwardSpent > 0.91) Then
        Fn_SlowSpender = "FALSE"
    ElseIf (Abs(PctTermExp - PctAwardSpent) > 0.25) Then
        Fn_SlowSpender = "True"
    Else
        Fn_SlowSpender = "False"
    End If
ElseIf Program = "HPAC" Then
    If (PctAwardSpent > 0.91) Then
        Fn_SlowSpender = "FALSE"
    ElseIf (Abs(PctTermExp - PctAwardSpent) > 0.25) Then
        Fn_SlowSpender = "True"
    Else
        Fn_SlowSpender = "False"
    End If
End If
End Function
 
Function Fn_ExpDate(Balance As Currency) As Date
 
'Public LOCCS_Rec(20) As Variant    'Record values to be written
    'LOCCS_Rec(4)= Program          'LOCCS A67 Report File Name
    'LOCCS_Rec(7)= EFF_DATE         'LOCCS Report
    'LOCCS_Rec(8)= Start_Date       'LOCCS Report. If no date in report then see code
    'LOCCS_Rec(9)= Term             'LOCCS Report or Derived from "Activity" & "Program"
    'LOCCS_Rec(10)= Exp_Date        'Derived from "Term_months" & "StartDate"
 
    Dim StartDate, EffDate, ExpDate As Date
    Dim Term As Double
 
    On Error GoTo ErrorHandler    ' Enable error-handling routine
    Program = LOCCS_Rec(4)
    Term = CDbl(LOCCS_Rec(9))
 
    If (Program = "SPC") Or (Program = "YB") Or (Program = "HPAC") Then
        StartDate = CDate(LOCCS_Rec(7))
    Else
        StartDate = CDate(LOCCS_Rec(8))
    End If
 
    If (Program = "SPC") Then       'And (Term = 0) Then    'Edit 061405
'        Fn_ExpDate = #1/1/100#
'    ElseIf (Program = "SPC") And (Term > 0) Then
'        Fn_ExpDate = DateAdd("m", Term, StartDate - 1)
    ElseIf (Program = "SHP") And (StartDate = #1/1/100#) Then
        Fn_ExpDate = #1/1/100#
    ElseIf (Program = "SHP") And (StartDate <> #1/1/100#) Then
        Fn_ExpDate = DateAdd("m", Term, StartDate - 1)
    ElseIf (Program = "YB") Or (Program = "HPAC") Then
        Fn_ExpDate = DateAdd("m", Term, StartDate - 1)
    End If
    GoTo Fn_End:
 
ErrorHandler:        ' Error-handling routine.
    Select Case Err.Number    ' Evaluate error number.
        Case 55
 
        Case Else
            ' Handle other situations here...
    End Select
    Err.Clear    ' Clear Err object fields
Fn_End:
End Function
Sub Parse_BLILine(Retstring As String)
 
'Public BLICodes(7, 29) As Variant
    'Public BLICodes(0,n)   'LOCCS numeric BLI Codes
    'Public BLICodes(1,n)   'Manual Assignment of Activity Code (SS,Admin,Oper,Lease,SRA,TRA, etc)
    'Public BLICodes(2,n)   'LOCCS BLI Authorization
    'Public BLICodes(3,n)   'LOCCS BLI Expenditures
    'Public BLICodes(4,n)   'Manual Calculation of BLI Balance
    'Public BLICodes(5,n)   'Running Total of each BLI Authorization
    'Public BLICodes(6,n)   'Running Total of each BLI Expenditure
    'Public BLICodes(7,n)   'Concatenated BLI Descriptions (PRA,SS,OPER,LEASE, etc)
 
    BLICodes(0, 0) = "1000"   'SRA Rental Assistance        [SPC]
    BLICodes(0, 1) = "1010"   'Acquisition(SHP/HP)/SRA(SPC)                  [SHP,HP]
    BLICodes(0, 2) = "1020"   'Rehabilitation               [SHP,HP(rehab&NC)]
    BLICodes(0, 3) = "1021"   'New Construction             [SHP]
    BLICodes(0, 4) = "1022"   'Subst Rehabilitation         [SHP]
    BLICodes(0, 5) = "1023"   'Moderate Rehabilitation      [SHP]
    BLICodes(0, 6) = "1030"   'Operating Costs              [SHP,HP]
    BLICodes(0, 7) = "1040"   'Rental Assistance            [SHP,HP]
    BLICodes(0, 8) = "1050"   'Supportive Services          [SHP,HP]
    BLICodes(0, 9) = "1051"   'HMIS Costs                   [SHP]
    BLICodes(0, 10) = "1060"   'Administrative              [SHP,HP,SPC]
    BLICodes(0, 11) = "1070"   'Child Care                  [SHP]
    BLICodes(0, 12) = "1080"   'Employment Assistance       [SHP]
    BLICodes(0, 13) = "1090"   'Relocation                  [SHP]
    BLICodes(0, 14) = "1100"   'Leasing                     [SHP]
    BLICodes(0, 15) = "1110"   'Repair and Maintenance      [SHP]
    BLICodes(0, 16) = "1111"   'Prevention(RH)              [SHP]
    BLICodes(0, 17) = "1112"   'Capacity Building (RH)      [SHP]
    BLICodes(0, 18) = "1120"   'Other                       [SHP,HP]
    BLICodes(0, 19) = "1130"   'Funds on Hold               [SHP]
    BLICodes(0, 20) = "2000"   'TRA Rental Assistance       [SPC]
    BLICodes(0, 21) = "2070"   'Outreach and Recruitment    [YB]
    BLICodes(0, 22) = "2080"   'Education & Job Training    [YB]
    BLICodes(0, 23) = "2090"   'Wages Stipends & Benefits   [YB]
    BLICodes(0, 24) = "2100"   'Counslng Support & Devlp    [YB]
    BLICodes(0, 25) = "2110"   'Training and Tech Assist    [YB]
    BLICodes(0, 26) = "2120"   'Job Placement & FollowUp    [YB]
    BLICodes(0, 27) = "2130"   'Administration              [YB]
    BLICodes(0, 28) = "3000"   'PRA Rehab Rental Assist     [SPC]
    BLICodes(0, 29) = "3100"   'PRA Non-Rehab Rent Assist   [SPC]
 
    BLICodes(1, 0) = "SRA"      'SRA Rental Assistance      [SPC]
    BLICodes(1, 1) = "ACQ"      'Acquisition                [SHP,HP]
    BLICodes(1, 2) = "REH"      'Rehabilitation             [SHP,HP(rehab&NC)]
    BLICodes(1, 3) = "NC"       'New Construction           [SHP]
    BLICodes(1, 4) = "SREHAB"   'Subst Rehabilitation       [SHP]
    BLICodes(1, 5) = "MREHAB"   'Moderate Rehabilitation    [SHP]
    BLICodes(1, 6) = "OPER"     'Operating Costs            [SHP,HP]
    BLICodes(1, 7) = "RA"       'Rental Assistance          [SHP,HP]
    BLICodes(1, 8) = "SS"       'Supportive Services        [SHP,HP]
    BLICodes(1, 9) = "HMIS"     'HMIS Costs                 [SHP]
    BLICodes(1, 10) = "ADMIN"   'Administrative             [SHP,HP,SPC]
    BLICodes(1, 11) = "CHILDC"  'Child Care                 [SHP]
    BLICodes(1, 12) = "EMPASS"  'Employment Assistance      [SHP]
    BLICodes(1, 13) = "RELO"    'Relocation                 [SHP]
    BLICodes(1, 14) = "LEASE"   'Leasing                    [SHP]
    BLICodes(1, 15) = "REPMAN"  'Repair and Maintenance     [SHP]
    BLICodes(1, 16) = "PREV"    'Prevention(RH)             [SHP]
    BLICodes(1, 17) = "CAPBLD"  'Capacity Building (RH)     [SHP]
    BLICodes(1, 18) = "OTHER"   'Other                      [SHP,HP]
    BLICodes(1, 19) = "FOH"     'Funds on Hold              [SHP]
    BLICodes(1, 20) = "TRA"     'TRA Rental Assistance      [SPC]
    BLICodes(1, 21) = "OUTR"    'Outreach and Recruitment   [YB]
    BLICodes(1, 22) = "EDUC"    'Education & Job Training   [YB]
    BLICodes(1, 23) = "STIPEND" 'Wages Stipends & Benefits  [YB]
    BLICodes(1, 24) = "COUNSEL" 'Counslng Support & Devlp   [YB]
    BLICodes(1, 25) = "TA"      'Training and Tech Assist   [YB]
    BLICodes(1, 26) = "JOBPLAC" 'Job Placement & FollowUp   [YB]
    BLICodes(1, 27) = "YBAMIN"  'Administration             [YB]
    BLICodes(1, 28) = "PRAW"    'PRA Rehab Rental Assist    [SPC]
    BLICodes(1, 29) = "PRA"     'PRA Non-Rehab Rent Assist  [SPC]
 
    Dim Authorized, Disbursed, Balance As Currency
    Dim BLIStart As Integer, i As Integer
    Dim Code As String
 
 
    Code = Trim(Mid(Retstring, 1, 12))
 
    If (Program = "SPC") And Code = "1010" Then 'Correct the Problem with SPC having two codes for "SRA"
        BLICodes(1, 1) = "SRA"
    Else
        BLICodes(1, 1) = "ACQ"
    End If
 
    For i = 0 To BLIFldCnt
        If Program = "YB" And Code < "2070" Then
 
        ElseIf Code = BLICodes(0, i) Then
            Authorized = Mid(Retstring, 38, 17)                 'BLI Authorized Amount for this record
            BLICodes(2, i) = Authorized
            Disbursed = Mid(Retstring, 57, 18)                  'BLI Expenditure Amount for this record
            BLICodes(3, i) = Disbursed
            BLICodes(4, i) = Str(Authorized - Disbursed)             'BLI Balance for this record
            BLICodes(5, i) = CCur(BLICodes(5, i)) + Authorized   'BLI Authorizations Running Total for all Records
            BLICodes(6, i) = CCur(BLICodes(6, i)) + Disbursed   'BLI Expenditures Running Total for all Records
            LOCCS_Rec(17) = LOCCS_Rec(17) + "," + BLICodes(1, i)                                 'BLI_Codes
            Exit For
        ElseIf i = BLIFldCnt Then
            MsgBox (Program + " - invalid budget code, " + Code + " - ABORT")
            PgmAbort = 1
            Exit For
        End If
    Next i
End Sub
Sub Parse_GrantLine(Retstring As String)
'Public LOCCS_Rec(19) As Variant 'Record values to be written
Dim ReadLine As String
        'Parse the data fields
            LOCCS_Rec(0) = Trim(Mid(Retstring, 1, 15))          'Grant_Nmbr
            LOCCS_Rec(0) = Replace(LOCCS_Rec(0), "-", "")       'Erase "-" Char in Grant_Nmbr
            LOCCS_Rec(1) = Trim(Mid(Retstring, 1, 15))          'LOCCS-Nmbr
            LOCCS_Rec(3) = Fn_State(Retstring)                  'State
            LOCCS_Rec(4) = Program                              'Program
            LOCCS_Rec(5) = Trim(Mid(Retstring, 18, 36))         'Grantee_Nm
            LOCCS_Rec(6) = Trim(Mid(Retstring, 59, 11))         'Grantee_TID
            LOCCS_Rec(7) = Fn_DateCleanup(Retstring, 7)         'Eff_Date
            LOCCS_Rec(8) = Fn_DateCleanup(Retstring, 8)         'Start_Date
            LOCCS_Rec(2) = Fn_Year(Retstring)                   'Year-Done after datecleanup. From DEPCON A67 Data
            LOCCS_Rec(9) = Fn_Term((Retstring), 1)              'Term_months (Pass = 1 Needs to be adjusted before writing)
            LOCCS_Rec(10) = ""                                  'Expiration Date
            LOCCS_Rec(11) = Fn_MonthsElapsed()                  'Months Elapsed ( ReportDate-EffDate)
            LOCCS_Rec(12) = ""                                  'Spare (Activity)
            LOCCS_Rec(13) = "0"                                 'Authorized
            LOCCS_Rec(14) = "0"                                 'Disbursed
            LOCCS_Rec(15) = "0"                                 'Balance_Calc
            LOCCS_Rec(16) = stDepconDatex                       'LOCC_RptDate
            LOCCS_Rec(17) = ""                                  'BLI_Codes
 
End Sub
Sub Parse_LOCCSRec()
'------------------------------------------------------------------------------------
'Enter here only when you have a complete LOCCS record to write. Note that a record
'may not have BLI data if it has not been completely defined to LOCCS or is an entry
'that is summary for multiple grant numbers that follow
'-------------------------------------------------------------------------------------
'Public BLICodes(7, 29) As Variant
    'Public BLICodes(0,n)   'LOCCS numeric BLI Codes
    'Public BLICodes(1,n)   'Manual Assignment of Activity Code (SS,Admin,Oper,Lease,SRA,TRA, etc)
    'Public BLICodes(2,n)   'LOCCS BLI Authorization
    'Public BLICodes(3,n)   'LOCCS BLI Expenditures
    'Public BLICodes(4,n)   'Manual Calculation of BLI Balance
    'Public BLICodes(5,n)   'Running Total of each BLI Authorization
    'Public BLICodes(6,n)   'Running Total of each BLI Expenditure
    'Public BLICodes(7,n)   'Concatenated BLI Descriptions (PRA,SS,OPER,LEASE, etc)
 
Dim i As Integer
Dim Authorized As Currency
Dim Disbursed As Currency
Dim Balance As Currency
    Authorized = 0: Disbursed = 0: Balance = 0
    Program = LOCCS_Rec(4)
    For i = 0 To BLIFldCnt
        'Calculate single record total
        If BLICodes(2, i) <> "" Then
            Authorized = Authorized + CCur(BLICodes(2, i))
            Disbursed = Disbursed + CCur(BLICodes(3, i))
            Balance = Authorized - Disbursed
        End If
    Next i
    LOCCS_Rec(13) = Str(Authorized)
    LOCCS_Rec(14) = Str(Disbursed)
    LOCCS_Rec(15) = Str(Balance)
'    LOCCS_Rec(7) = Fn_DateCleanup(7)
'    LOCCS_Rec(8) = Fn_DateCleanup(8)
'    LOCCS_Rec(9) = Fn_DateCleanup(9)
    LOCCS_Rec(9) = Fn_Term(Retstring, 2)        'Calculate the term for SPC grants
    If Program = "SPC" Then
        LOCCS_Rec(10) = "No Data"        'A67 file will not include estimates(June05)
    Else
        LOCCS_Rec(10) = CStr(Fn_ExpDate(Balance))   'Calculate Expiration Date for grants with a non-zero balance
    End If
    LOCCS_Rec(11) = CStr(Fn_MonthsElapsed())      'Calculate Months Expired
    LOCCS_Rec(19) = CStr(Fn_PctAwardSpent(Authorized, Disbursed))    'Calculate % of Award Spent
    LOCCS_Rec(18) = CStr(Fn_PctTermExp())       'Calculate % of Term that has expired
    LOCCS_Rec(20) = Fn_SlowSpender()
    LOCCS_Rec(21) = Fn_RestCov()
    LOCCS_Rec(22) = Fn_ActiveGrant()
    'LOCCS_Rec(23) = Fn_CoCTag()
    'LOCCS_Rec(23) = Fn_COCID(LOCCS_Rec(4)) ':112206 Not Available-only 0-22
 
End Sub
Sub Parse_BLITotals()
'Public BLICodes(7, 29) As Variant
    'Public BLICodes(0,n)   'LOCCS numeric BLI Codes
    'Public BLICodes(1,n)   'Manual Assignment of Activity Code (SS,Admin,Oper,Lease,SRA,TRA, etc)
    'Public BLICodes(2,n)   'LOCCS BLI Authorization
    'Public BLICodes(3,n)   'LOCCS BLI Expenditures
    'Public BLICodes(4,n)   'Manual Calculation of BLI Balance
    'Public BLICodes(5,n)   'Running Total of each BLI Authorization
    'Public BLICodes(6,n)   'Running Total of each BLI Expenditure
    'Public BLICodes(7,n)   'Concatenated BLI Descriptions (PRA,SS,OPER,LEASE, etc)
    Dim BLIError(1, 29) As Currency, Auth_Err As Currency, Disb_Err As Currency
    Dim t As String
    Dim i As Integer
    Dim BLI_Err As Boolean, Err_Tst As Boolean
 
     t = Chr(9)
     For i = 0 To BLIFldCnt
     If BLICodes(2, i) <> "0" Then
        BLICodes(5, i) = BLICodes(5, i) / 2 'Compensate for doubling the total with "Totals" record
        BLICodes(6, i) = BLICodes(6, i) / 2 'Compensate for doubling the total with "Totals" record
        BLIError(0, i) = CCur(BLICodes(2, i)) - BLICodes(5, i)  'Verify the Authorized File/Report totals
        BLIError(1, i) = CCur(BLICodes(3, i)) - BLICodes(6, i)  'Verify the Disbursed File/Report totals
        Auth_Err = Auth_Err + Abs(BLIError(0, i))
        Disb_Err = Disb_Err + Abs(BLIError(1, i))
     End If
    Next i
    If Auth_Err < 1 And Disb_Err < 1 Then
        BLI_Err = False
    Else
        BLI_Err = True
    End If
    Err_Tst = False
    If (Program = "SPC") And (Auth_Err > 1) Then Err_Tst = True
    If (Program <> "SPC") And (BLI_Err = True) Then Err_Tst = True
    If DBG = 1 Then Err_Tst = True
    If Err_Tst = True Then
    'Write the Report Reference and Internal Summary Totals to Output File
        tsout.Writeline ("BLICode" + t + "AuthSum" + t + "AuthRpt" + t + "AuthDiff" + t _
        + "DisbSum" + t + "DisbRpt" + t + "DisDiff")
        For i = 0 To BLIFldCnt
            tsout.Writeline BLICodes(0, i) + t + Str(BLICodes(5, i)) + t + BLICodes(2, i) + t + Str(BLIError(0, i)) _
            + t + Str(BLICodes(6, i)) + t + BLICodes(3, i) + t + Str(BLIError(1, i))
        Next i
        If DBG = 0 Then
            MsgBox ("There are compare errors between the Reports and the Database")
            tsout.Close
            tsin.Close
 
        End If
    End If
End Sub
Sub Parse_A67Rpts()
'----------------------------------------------------------------
'Read the LOCCS A67 Reports for SHP, SPC, YB and HOPWA and create
'four temporary text files that have only data lines.
'----------------------------------------------------------------
'----------------------------------------------------------------------------------
'This Public Array has information on all the LOCCS Reports being processed
'Public LocFiles(3, 125) As String
    'LocFiles(0,n)- The list of filenames with a "BKP" suffix in C:\LOCCS directory
    'LocFiles(1,n)- The Program Type Code SNAP,SPC,YB, etc
    'LocFiles(2,n)- The date of the report
    'LocFiles(3,n)- The first two lines  after "Page:" line of the report header
'-----------------------------------------------------------------------------------
 
    Const ForReading = 1, ForAppending = 8
    Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
    Dim Retstring As String, Pgm As String
    Dim fs, fsin, fsout, fin, fout, tsin, tsout, Found, i
    Dim Program As String
    Dim fnmbr As Integer
    Dim ThisDate As String
    Dim FileOut_nm1 As String
    Dim fnames(1, 3)
        fnames(0, 0) = "SHP_Temp.txt"
        fnames(0, 1) = "SPC_Temp.txt"
        fnames(0, 2) = "YB_Temp.txt"
        fnames(0, 3) = "HPAC_Temp.txt"
        fnames(1, 0) = "SHP"
        fnames(1, 1) = "SPC"
        fnames(1, 2) = "YB"
        fnames(1, 3) = "HPAC"
 
        Set fs = CreateObject("Scripting.FileSystemObject")
    For fnmbr = 0 To 3        'Set up file "FileOut_Nm" for output
        Pgm = fnames(1, fnmbr)
        FileOut_nm1 = fnames(0, fnmbr)
        Set tsout = fs.OpenTextFile(FileOut_nm1, ForAppending, True, TristateFalse)
 
 
        For i = 0 To 125
            If LocFiles(2, i) <> "" Then
                ThisDate = CDate(LocFiles(2, i))
            End If
            If (LocFiles(1, i) = Pgm) And (ThisDate = MostRecent) Then
                Set tsin = fs.OpenTextFile(LocFiles(0, i), ForReading, TristateFalse) 'Open an input file
                tsout.Writeline "Program:    " + fnames(1, fnmbr) + "     " + LocFiles(0, i) + "     " + LocFiles(2, i)
                Do While tsin.AtEndOfStream <> True
                    Retstring = tsin.ReadLine
                    If Trim(Mid(Retstring, 70, 9)) = "Eff Dt:" Then 'This is a grant data line
                        tsout.Writeline (Retstring)
                    ElseIf Val(Mid(Retstring, 1, 11)) > 999 Then    'This is a Budget Line Item (BLI) lie
                        tsout.Writeline (Retstring)
                    ElseIf Trim(Mid(Retstring, 1, 35)) = "TOTAL" Then 'This is a summary total line for last record
                        tsout.Writeline (Mid(Retstring, 1, 114))
                    ElseIf Trim(Mid(Retstring, 176, 20)) = "Line Item Totals" Then 'This is the summary report at EOF
                        tsout.Writeline (Trim(Mid(Retstring, 176, 50)))
                    End If
                Loop
                tsout.Writeline ("EOFEOF")
            tsin.Close
            End If
        Next i
        tsout.Close
    Next fnmbr
'    Set fout = fsout.GetFile("A67_All.txt")     'Create a new output file
    Set tsout = fs.OpenTextFile("A67_All.txt", ForAppending, True, TristateFalse)
    For fnmbr = 0 To 3
        Set tsin = fs.OpenTextFile(fnames(0, fnmbr), ForReading, TristateFalse) 'Open an input file
        Do While tsin.AtEndOfStream <> True
            Retstring = tsin.ReadLine
            tsout.Writeline (Retstring)
        Loop
        tsin.Close
    Next fnmbr
    tsout.Close
    Set tsout = fs.getfile("A67_All.txt")     'Create a new output file
    tsout.Copy FileOut_nm + ".txt", True
End Sub
Sub Controlm()
    Dim wkb As Workbook
 
    If wkb1 Is Nothing Then
       For Each wkb In Workbooks
           If InStr(1, wkb.Name, "BOSSNAP") = 1 Then
               Set wkb1 = wkb                              'Set Public Variable Wkb1
               Exit For
           End If
       Next wkb
    End If
      wkb1.Activate
      Worksheets("Macros").Activate
'    MsgBox ("SELECT A BUTTON")
End Sub
Sub CONTROL_P()
'
'
 
    Dim stDate As String
    Dim stFileName As String
    Dim stFullName As String
    Dim Msg1 As String
    Dim Pgm As String
    Dim RW As String
    Dim i As Long
    Dim t As Single
    t = Timer
 
    If Fn_IsWorkbookOpen(stWkb3Name) Then Exit Sub
    Pgm = Program           'Set the local variable from public variable
    Application.ScreenUpdating = False
    wkb2.Activate
    Range("A1").CurrentRegion.Select
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Range("A1").Select
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=stWkb3Name  'Use Name created from last filter
    Application.DisplayAlerts = True
    Set wkb3 = Workbooks(stWkb3Name)     'Set Public Variable with filter output file
    Debug.Print "Control_P", , , Format(Timer - t, "#0.#00")
End Sub
    Sub EndOfFilter()
    '----------------------------------------------------------------------
    'Position the cursor at the end of data to show subtotals and text box
    '----------------------------------------------------------------------
 
    Dim StBt_A As String
    Dim StBt_B As String
    Dim StBt_C As String
    Dim StBt_D As String
 
    Dim Msg1 As String
    Dim i As Long
    Dim n As Long
    Dim t As Single
    Dim stTestData As String
    Dim lRows As Long
    Dim wks As Worksheet
 
    t = Timer
    n = iButtonNmbr + 1
    wkb3.Activate
    Sheets("Sheet1").Name = "Database"
    Sheets("Database").Activate
    With ActiveSheet
        .UsedRange  'Reset the last cell
    End With
    Application.DisplayAlerts = False
    wkb3.Save
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    '----------------------------------------------
    'Position the cursor to display the end of data
    'in the "Database" Worksheet only
    '----------------------------------------------
    Range("A1").Select
    i = Range(ActiveCell, ActiveCell.End(xlDown)).Rows.Count
    If i > 65000 Then       'For filters that return "zero" rows
        Cells(5, 1).Select
    ElseIf i < 20 Then      '20 or less rows position to "A2"
        Cells(2, 1).Select
    Else
        Cells(i, 1).Select  'more than 20 rows position to end of data
    End If
    '-----------------------------------------------------
    'Activate the "Summary Report" Worksheet if it exists
    'Otherwise default to "Database" Worksheet
    '-----------------------------------------------------
    For Each wks In Worksheets
        If wks.Name = "Summary Report" Then
            wks.Activate
            Exit For
        End If
    Next wks
    '-------------Update the "Test All" array --------------------
    i = Range(ActiveCell, ActiveCell.End(xlDown)).Rows.Count
    vTestAllArray(n, 1) = iButtonNmbr
    vTestAllArray(n, 2) = wkb3.Name
    vTestAllArray(n, 3) = Cells(i + 2, 1).Value
    vTestAllArray(n, 4) = Cells(i + 2, 18).Value
    vTestAllArray(n, 5) = Cells(i + 2, 19).Value
    vTestAllArray(n, 6) = Cells(i + 2, 20).Value
    vTestAllArray(n, 7) = Format(Timer - sSTButton, "#0.#00")
    'Cells(i + 4, 2).Select
    fmProgress.Hide
    Debug.Print "EndOfFilter", , Format(Timer - t, "#0.#00"); "  Save Workbook & position Cursor"
    'Debug.Print wkb3.Name, , Format(Timer - sSTButton, "#0.#00")
    '------------------For "Test All" only -------------------------
    If blTestAll = True Then
        Application.DisplayAlerts = False
        wkb3.Close
        Application.DisplayAlerts = True
    Else
        wkb1.Activate   ':062306 Insure that BOSSNAPS workbook displayed when WKB3 closed
        wkb3.Activate   ':062306
        PublicMsg = "Filtered sheet saved as " & Chr(10) & wkb3.Name & Chr(13) _
             & "ENTER CONTROL-M TO SELECT MORE OPTIONS"
        Application.ScreenUpdating = True
    End If
End Sub
Sub Expiring_Grants()
'-------------------------------------------------------
'Enter Subroutine with PV "Program" set to SHP or SPC
'Set PV "stbutton" to "Expiring Grants.xxx" that will be
'used by all subroutines to branch to specific routines
'-------------------------------------------------------
'Public Program As String            'SHP,SPC,YB,HPAC
    Dim ValidDate As Boolean
    Dim Opin As Variant
    Dim Msg As String
    Dim Msg1 As String, Title As String, stCalYear As String
    Dim Msg2 As String
    Dim iCalYear As Integer
    Dim stTemp As String
    Dim r As Range
    Dim iFromYr As Integer, iToYr As Integer
    Dim stFromYr As String, stToYr As String
    Dim stFileName As String
 
    '----------------------------------------
    'Program = "SHP" 'FOR DEBUG PURPOSES ONLY
    '----------------------------------------
    stbutton = "Expiring Grants" & "." & Program
    Call SetWkbObjects
    If Fn_IsWorkbookOpen(stWkb3Name) Then
        wkb1.Activate
        Worksheets("Macros").Activate
        MsgBox ("This filter has already been saved as" & Chr(13) & stWkb3Name & Chr(13) _
            & " SELECT ANOTHER OPTION")
        fmProgress.Hide
        Exit Sub
    End If
    'Request a valid year from the operator
    iExpYear = 0
    Do Until ValidDate = True
        Opin = Application.InputBox(prompt:="Enter Calendar Year between 1995 - 2015", Type:=1)
        If Opin = False Then Exit Sub
        If Opin > 1994 And Opin < 2016 Then
            iExpYear = Opin
            ValidDate = True
        Else
            ValidDate = False
        End If
    Loop
 
 fmProgress.Show vbModeless
    fmProgress.pcProgress (2)
    Call FilterA67              'Filter the A67 database using button criteria
    fmProgress.pcProgress (30)
    Call CONTROL_P              'Save the filtered data to a new file
    fmProgress.pcProgress (40)
    Call Pass2Filter
    fmProgress.pcProgress (45)
    Call HighlightRows          'If applicable, highlight rows that are questionable
    fmProgress.pcProgress (47)
    Call DeleteRows
    fmProgress.pcProgress (50)
    Call FormatPage          'Format the new file
    fmProgress.pcProgress (60)
    Call CopyTextBox            'Copy a textbox to end of new file
    fmProgress.pcProgress (70)
    Call FILTERSUBTOTALS        'Insert the Subtotals formulas to end of new file
    fmProgress.pcProgress (80)
    Call EndOfFilter            'Save the final filtered file and post a message
    fmProgress.Hide
End Sub
Sub Active_Grants(Pgm As String)
    Dim stCriteria As String
 
    If Pgm = "*" Then           'Set the public variable from the local
        Program = "ALL"
    Else
        Program = Pgm
    End If
    stbutton = "Active Grants" & "." & Program
 
    Call SetWkbObjects
    If Fn_IsWorkbookOpen(stWkb3Name) Then
        wkb1.Activate
        Worksheets("Macros").Activate
        MsgBox ("This filter has already been saved as" & Chr(13) & stWkb3Name & Chr(13) _
            & " SELECT ANOTHER OPTION")
        fmProgress.Hide
        Exit Sub
    End If
 
    fmProgress.Show vbModeless
    fmProgress.pcProgress (2)
    Call FilterA67              'Filter the A67 database using button criteria
    fmProgress.pcProgress (30)
    Call CONTROL_P              'Save the filtered data to a new file
    fmProgress.pcProgress (40)
    Call Pass2Filter
    fmProgress.pcProgress (45)
    Call HighlightRows          'If applicable, highlight rows that are questionable
    fmProgress.pcProgress (47)
    Call DeleteRows
    fmProgress.pcProgress (50)
    Call FormatPage          'Format the new file
    fmProgress.pcProgress (60)
    Call CopyTextBox            'Copy a textbox to end of new file
    fmProgress.pcProgress (70)
    Call FILTERSUBTOTALS        'Insert the Subtotals formulas to end of new file
    fmProgress.pcProgress (80)
    Call EndOfFilter            'Save the final filtered file and post a message
    fmProgress.Hide
End Sub
Sub Slow_Spenders(Pgm As String)
 
 
    Dim Opin As String
    Dim Msg1 As String, MsgSPC As String
 
    If Pgm = "*" Then           'Set the public variable from the local
        Program = "ALL"
    Else
        Program = Pgm
    End If
 
    stbutton = "Problem Spenders" & "." & Program
    Call SetWkbObjects
    If Fn_IsWorkbookOpen(stWkb3Name) Then
        wkb1.Activate
        Worksheets("Macros").Activate
        MsgBox ("This filter has already been saved as" & Chr(13) & stWkb3Name & Chr(13) _
            & " SELECT ANOTHER OPTION")
        fmProgress.Hide
        Exit Sub
    End If
 
    fmProgress.Show vbModeless
    fmProgress.pcProgress (2)
    Call FilterA67              'Filter the A67 database using button criteria
    fmProgress.pcProgress (30)
    Call CONTROL_P              'Save the filtered data to a new file
    fmProgress.pcProgress (40)
    Call Pass2Filter
    fmProgress.pcProgress (45)
    Call HighlightRows          'If applicable, highlight rows that are questionable
    fmProgress.pcProgress (47)
    Call DeleteRows
    fmProgress.pcProgress (50)
    Call FormatPage          'Format the new file
    fmProgress.pcProgress (60)
    Call CopyTextBox            'Copy a textbox to end of new file
    fmProgress.pcProgress (70)
    Call FILTERSUBTOTALS        'Insert the Subtotals formulas to end of new file
    fmProgress.pcProgress (80)
    Call EndOfFilter            'Save the final filtered file and post a message
    fmProgress.Hide
End Sub
Sub Restrictive_Covenants(Pgm As String)
'
'--------------------------------------------------------------------------------
' If a grant has an Acquisition, New Construction or Rehab Component flag it as
'requiring a Restrictive Covenant
'--------------------------------------------------------------------------------
 
    stbutton = "Restrictive Covenants.SHP"
    Call SetWkbObjects
    If Fn_IsWorkbookOpen(stWkb3Name) Then
        wkb1.Activate
        Worksheets("Macros").Activate
        MsgBox ("This filter has already been saved as" & Chr(13) & stWkb3Name & Chr(13) _
            & " SELECT ANOTHER OPTION")
        fmProgress.Hide
        Exit Sub
    End If
 
    fmProgress.Show vbModeless
    fmProgress.pcProgress (2)
    Call FilterA67              'Filter the A67 database using button criteria
    fmProgress.pcProgress (30)
    Call CONTROL_P              'Save the filtered data to a new file
    fmProgress.pcProgress (40)
    Call Pass2Filter
    fmProgress.pcProgress (45)
    Call HighlightRows          'If applicable, highlight rows that are questionable
    fmProgress.pcProgress (47)
    Call DeleteRows
    fmProgress.pcProgress (50)
    Call FormatPage          'Format the new file
    fmProgress.pcProgress (60)
    Call CopyTextBox            'Copy a textbox to end of new file
    fmProgress.pcProgress (70)
    Call FILTERSUBTOTALS        'Insert the Subtotals formulas to end of new file
    fmProgress.pcProgress (80)
    Call EndOfFilter            'Save the final filtered file and post a message
    fmProgress.Hide
End Sub
Sub ExpiredBalance(Pgm As String)
 
    If Pgm = "*" Then           'Set the public variable from the local
        Program = "ALL"
    Else
        Program = Pgm
    End If
 
    stbutton = "Expired Balance" & "." & Program
    Call SetWkbObjects
    If Fn_IsWorkbookOpen(stWkb3Name) Then
        wkb1.Activate
        Worksheets("Macros").Activate
        MsgBox ("This filter has already been saved as" & Chr(13) & stWkb3Name & Chr(13) _
            & " SELECT ANOTHER OPTION")
        fmProgress.Hide
        Exit Sub
    End If
 
    fmProgress.Show vbModeless
    fmProgress.pcProgress (2)
    Call FilterA67              'Filter the A67 database using button criteria
    fmProgress.pcProgress (30)
    Call CONTROL_P              'Save the filtered data to a new file
    fmProgress.pcProgress (40)
    Call Pass2Filter
    fmProgress.pcProgress (45)
    Call HighlightRows          'If applicable, highlight rows that are questionable
    fmProgress.pcProgress (47)
    Call DeleteRows
    fmProgress.pcProgress (50)
    Call FormatPage          'Format the new file
    fmProgress.pcProgress (60)
    Call CopyTextBox            'Copy a textbox to end of new file
    fmProgress.pcProgress (70)
    Call FILTERSUBTOTALS        'Insert the Subtotals formulas to end of new file
    fmProgress.pcProgress (80)
    Call EndOfFilter            'Save the final filtered file and post a message
    fmProgress.Hide
End Sub
Sub A67Concatenate()
 
 
    'Public LocFiles(4, 125) As String
        'LocFiles(0,n)- The list of filenames with a "BKP" suffix in C:\LOCCS directory
        'LocFiles(1,n)- The Program Type Code SNAP,SPC,YB, etc
        'LocFiles(2,n)- The date of the report
        'LocFiles(3,n)- The CPD Office Name
        'LocFiles(4,n)- "Processed" or ""
 
'    Public dtDepconDate As Date        'The date of the newest DEPCON monthly report group
'    Public stDepConFileNm As String    'The DepCon File Name to be saved
 
    Const ForReading = 1, ForAppending = 8
    Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
    Dim Retstring As String, Pgm As String, FilePath As String
    Dim fs, fsin, fsout, fin, fout, tsin, tsout, Found, i
    Dim t As Single
    t = Timer
    ChDir (stMacroDir)
    Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FileExists(stDepConFileNm + ".txt") Then Kill stDepConFileNm + ".txt"
    Set tsout = fs.OpenTextFile(stDepConFileNm + ".txt", ForAppending, True, TristateFalse)
'-----------------------------------------------------------------------------------------
'Copy/Concatenate each SHP, SPC, YB and HOPWAC file in monthly group to a single text file.
'Mark the beginning and end of each file for a second pass that will remove all extraneous lines
'-----------------------------------------------------------------------------------------
 
    For i = 0 To 125
        If (LocFiles(2, i) = "") Then
            Exit For
        ElseIf LocFiles(2, i) = stDepconDatex Then  'Process only the newest files
            FilePath = LocFiles(0, i)
            Pgm = LocFiles(1, i)
            If Pgm = "SNAP" Then
                Pgm = "SHP"
            ElseIf Pgm = "SPCR" Then
                Pgm = "SPC"
            End If
            'Debug.Print "Program " & Pgm & "  " & LocFiles(0, i)
            tsout.Writeline "Program:    " + Pgm + "    " + LocFiles(0, i) + "     " + LocFiles(2, i)
            Set tsin = fs.OpenTextFile(FilePath, ForReading, TristateFalse) 'Open an input file
            Do While tsin.AtEndOfStream <> True
                Retstring = tsin.ReadLine
                If (Mid(Retstring, 1, 3)) = "BVB" Then  'Fix for line beginning with "BVB"(635 characters)
                        'skip this line
                ElseIf Len(Retstring) > 590 Then    ':090503 where did this line come from??
                        'skip this line
                Else
                    tsout.Writeline (Retstring)
                End If
            Loop
            tsin.Close
            tsout.Writeline ("EOFEOF")
        End If
    Next i
    tsout.Close
    Debug.Print "    A67Concatenate", Format((Timer - t), "#0.#00"), "Copy all BKP files to a single A67 file"
End Sub
Sub A67ParseMonthlyReport()
'---------------------------------------------------------------------------------
'Read file "A67.Office Name.mmddyyyy.txt" and remove all headers, print control
'characters and non-data lines to a file called "A67All.txt"
'---------------------------------------------------------------------------------
    'Public FileOut_nm As String     'Text file containing all A67 reports for one month
    'Public LocFiles(4, 125) As String
        'LocFiles(0,n)- The list of filenames with a "BKP" suffix in C:\LOCCS directory
        'LocFiles(1,n)- The Program Type Code SNAP,SPC,YB, etc
        'LocFiles(2,n)- The date of the report
        'LocFiles(3,n)- The CPD Office Name
        'LocFiles(4,n)- "Processed" or ""
 
    Const ForReading = 1, ForAppending = 8
    Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
    Dim Retstring As String
    Dim Pgm As String
    Dim blLoccsErr As Boolean   ':100801 This is for 15 digit grants that should not be in LOCCS
    Dim lLoccsErr As Long       ':100801 This is for 15 digit grants that should not be in LOCCS
    Dim fs, fsin, fsout, fin, fout, tsin, tsout, Found, i
    Dim EndOfList As Boolean
    Dim FileDate As String, FOutDate As String
    Dim stFileIn As String
    Dim stFileOut As String
    Dim t As Single
    t = Timer
    ChDir (stMacroDir)
    stFileOut = "A67_ALL.txt"
    stFileIn = stDepConFileNm + ".txt"
    Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FileExists(stFileOut) Then Kill stFileOut
    Set tsout = fs.OpenTextFile(stFileOut, ForAppending, True, TristateFalse) 'Open LOCCS_ALL Output file
    Set tsin = fs.OpenTextFile(stFileIn, ForReading, TristateFalse) 'Open an input file
    '------------------- STRIP ALL LINES EXCEPT FOR VALID DATA LINES------------
    Do While tsin.AtEndOfStream <> True
        Retstring = tsin.ReadLine
        If Trim(Mid(Retstring, 70, 9)) = "Eff Dt:" Then 'This is a grant data line
            If Len(Trim(Mid(Retstring, 1, 17))) = 16 Then   ':100801 fIX FOR NEW 15 DIGIT PROJECTS THAT ARE LOCCS ERRORS
                blLoccsErr = True
                'Debug.Print Retstring
               lLoccsErr = lLoccsErr + 1
            Else                            'THIS IS A VALID 15 DIGIT PROJECT
                blLoccsErr = False
                tsout.Writeline (Retstring)
            End If
        ElseIf Trim(Mid(Retstring, 1, 8)) = "Program:" Then    'This is a A67 beginning of file marker
            tsout.Writeline (Retstring)
        ElseIf IsNumeric(Mid(Retstring, 1, 11)) Then    'This is a Budget Line Item (BLI) line
            If blLoccsErr = False Then          ':100801 FIX FOR 15 DIGIT LOOCS ERRORS
                tsout.Writeline (Retstring)
            Else
                '---Ignore a BLI line that follows a LoccsErr Line
            End If
        ElseIf Trim(Mid(Retstring, 1, 35)) = "TOTAL" Then 'This is a summary total line for last record
            tsout.Writeline (Mid(Retstring, 1, 114))
        ElseIf Trim(Mid(Retstring, 176, 20)) = "Line Item Totals" Then 'This is the summary report at EOF
            tsout.Writeline (Trim(Mid(Retstring, 176, 50)))
        ElseIf Trim(Mid(Retstring, 1, 10)) = "EOFEOF" Then    'This is a A67 end of file marker
            tsout.Writeline (Retstring)
        End If
    Loop
    tsin.Close
    tsout.Close
    Debug.Print "    A67ParseMonthlyReport", Format((Timer - t), "#0.#00"), "LOOCSErr= "; lLoccsErr; " Strip all but data lines"
End Sub
Sub A67RptCleanup()
'Public RptDate As String
'Public FileOut_nm As String     'Text file containing all A67 reports for one month
'Public BosnapDir As String
'Public BosnapNm As String
'Public stDEPCONDir As String
'Public LocFiles(4, 125) As String
    'LocFiles(0,n)- The list of filenames with a "BKP" suffix in C:\LOCCS directory
    'LocFiles(1,n)- The Program Type Code SNAP,SPC,YB, etc
    'LocFiles(2,n)- The date of the report
    'LocFiles(3,n)- The CPD Office Name
    'LocFiles(4,n)- "Processed" or ""
    Dim Source As String
    Dim Destination As String
    Dim DepconDestPath As String
    Dim DepconSourcePath As String
    Dim fs As Variant, fs1 As Variant
    Dim i As Long
    Dim junk As String
    Dim f As Variant
 
    Source = FileOut_nm
    Destination = BosnapDir + FileOut_nm
 
    Workbooks(Source + ".xls").Close SaveChanges:=True
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set fs1 = CreateObject("Scripting.FileSystemObject")
    If (fs.FileExists("A67_All.txt")) Then Kill "A67_All.txt"
    If (fs.FileExists("LOCCS_All.txt")) Then Kill "LOCCS_All.txt"
    If (stDEPCONDir + Source) <> Destination Then
        If (fs.FileExists(Destination + ".txt")) Then Kill Destination + ".txt"
        If (fs.FileExists(Destination + ".xls")) Then Kill Destination + ".xls"
        If (fs.FileExists(Source + ".txt")) Then
             fs.movefile Source + ".txt", Destination + ".txt"
             fs.movefile Source + ".xls", Destination + ".xls"
        End If
    End If
    '--------------------------------------------------------------------------
    'Move the A67 report files to an archive folder or delete them if they have
    'already been moved.
    '--------------------------------------------------------------------------
'    If Not FS1.folderexists(stDEPCONDir & "Archive") Then MkDir (stDEPCONDir & "Archive")
'    For i = 0 To 125
'            If LocFiles(0, i) <> "" Then
'            DepconDestPath = stDEPCONDir & "Archive\" & LocFiles(0, i)
'            DepconSourcePath = stDEPCONDir & LocFiles(0, i)
'            If Not (FS.FileExists(DepconDestPath)) Then
'                FS.movefile DepconSourcePath, DepconDestPath
'                LocFiles(0, i) = ""
'            Else    'This path used only if the A67 reports exist
'                    'in both the source and destination folders
'                Set f = FS.GetFile(DepconSourcePath)
'                f.Attributes = 0            'Clear the read only file attribute
'                Kill (DepconSourcePath)     'Delete the file in the source folder
'            End If
'        End If
'    Next i
End Sub
Function Fn_GetFileName(stFullName As String) As String
   '----------------------------------------------------------
   'GetFileName returns the file name, such as Cash.xls from
   'the end of a full path such as C:\Data\Project1\Cash.xls
   'stFullName is returned if no path separator is found
   '----------------------------------------------------------
   Dim stPathSep As String       'Path Separator Character
   Dim iFNLength As Integer      'Length of stFullName
   Dim i As Integer
 
   stPathSep = Application.PathSeparator
   iFNLength = Len(stFullName)
   'Find last path separator character, if there is one
   For i = iFNLength To 1 Step -1
      If Mid(stFullName, i, 1) = stPathSep Then Exit For
   Next i
   Fn_GetFileName = Right(stFullName, iFNLength - i)
End Function
Function Fn_IsWorkbookOpen(stName As String) As Boolean
    'stName is the filename without path
 
    Dim wkb As Workbook
 
    On Error Resume Next
    Set wkb = Workbooks(stName)
    If Not wkb Is Nothing Then
        Fn_IsWorkbookOpen = True
    End If
End Function
Sub A67Setup()
 
 '-------------------------------------------------------------------
 'Find all the A67 reports with replacement code for "Application.FileSearch"
 'Note that the original version returned a full pathname and this mofified
 'version must do the same.
 '-------------------------------------------------------------------
    Dim i As Integer, icount As Integer
    Dim x As Integer
    Dim fs As Variant
    Dim fs1 As Variant
    Dim f As Variant
    Dim f1 As Variant
    Dim fc As Variant
    Dim PRArray As Variant
    Dim s As String
    Dim vafilename As Variant
    Dim Retstring As String
    Dim dtA67ThisDate As Date
    Dim stA67ThisDate As String
    Dim dtA67NewestDate As String
    Dim stMonth As String, stDay As String, stYear As String
    Dim t As Single
    Dim stFileSearch As String
 
    t = Timer
    stMacroDir = ThisWorkbook.Path
        stFileSearch = "A67R1.*.????20??.xls"
'----------------------------MAIN LOOP-------------------------------------
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(stMacroDir)
    Set fc = f.Files    'Create a list object of all files in BOSSNAPS+ Directory
    ReDim PRArray(1)                            '------Clear the PRArray dimensions-----
    For Each f1 In fc                           'Test each file in list
        s = f1.Name                             'Get the filename
        If (s Like stFileSearch) Then
            s = ThisWorkbook.Path & "\" & s     'Create a full pathname to be compatible with original code
            icount = icount + 1
            ReDim Preserve PRArray(icount)
            PRArray(icount) = s
        End If
    Next
    If icount = 0 Then
        ReDim PRArray(0)    ':092507
        stA67xlsDate = #1/1/100#
        stA67FullNm = ""
        Exit Sub
    End If
    blA67Reports = True
    dtA67NewestDate = #1/1/100#                 'A67 reports in BOSSNAPS Directory
    For i = 1 To UBound(PRArray)                'Find the newest A67 Report
        Retstring = PRArray(i)
        x = InStr(1, Retstring, ".xls") - 8
        stA67ThisDate = Mid(Retstring, x, 8)
        stMonth = Mid(stA67ThisDate, 1, 2)
        stDay = Mid(stA67ThisDate, 3, 2)
        stYear = Mid(stA67ThisDate, 5, 4)
        dtA67ThisDate = CVDate(stMonth & "/" & stDay & "/" & stYear)
        If dtA67ThisDate > dtA67NewestDate Then
            dtA67NewestDate = dtA67ThisDate
            stA67xlsDate = stA67ThisDate        'Set the Public Variable
            stA67FullNm = Retstring             'Set the Public Variable
            dtA67xlsDate = dtA67NewestDate      'Set the Public Variable
            'Debug.Print RetString & "  " & dtA67NewestDate
        End If
    Next i
    stA67Nm = Fn_GetFileName(stA67FullNm)   'Set the Public Variable
    Debug.Print "    A67Setup", , Format((Timer - t), "#0.#00"), stA67FullNm
End Sub
Sub A67Setup_original()
 
 '-------------------------------------------------------------------
 'Find all the A67 reports using Application.FileSearch Method
 '-------------------------------------------------------------------
    Dim i As Integer, icount As Integer
    Dim fs As Variant
    Dim vafilename As Variant
    Dim Retstring As String
    Dim dtA67ThisDate As Date
    Dim stA67ThisDate As String
    Dim dtA67NewestDate As String
    Dim stMonth As String, stDay As String, stYear As String
    Dim t As Single
 
    t = Timer
    stMacroDir = ThisWorkbook.Path
    Set fs = Application.FileSearch
    With fs
        .NewSearch
        .LookIn = stMacroDir
        .SearchSubFolders = False
        .Filetype = msoFileTypeAllFiles
        .Filename = "A67R1.*.????200?.xls"
        icount = .Execute
        If icount = 0 Then
            dtA67xlsDate = #1/1/100#                'NO A67 reports in BOSSNAPS Directory
            stA67FullNm = ""                    'Set the Public Variable
            Exit Sub
        Else
            blA67Reports = True
            dtA67NewestDate = #1/1/100#         'A67 reports in BOSSNAPS Directory
            For Each vafilename In .FoundFiles  'Find the newest A67 Report
                Retstring = vafilename
                i = InStr(1, Retstring, ".xls") - 8
                stA67ThisDate = Mid(Retstring, i, 8)
                stMonth = Mid(stA67ThisDate, 1, 2)
                stDay = Mid(stA67ThisDate, 3, 2)
                stYear = Mid(stA67ThisDate, 5, 4)
                dtA67ThisDate = CVDate(stMonth & "/" & stDay & "/" & stYear)
                If dtA67ThisDate > dtA67NewestDate Then
                    dtA67NewestDate = dtA67ThisDate
                    stA67xlsDate = stA67ThisDate        'Set the Public Variable
                    stA67FullNm = Retstring             'Set the Public Variable
                    dtA67xlsDate = dtA67NewestDate      'Set the Public Variable
                    'Debug.Print RetString & "  " & dtA67NewestDate
                End If
            Next vafilename
        End If
    End With
    stA67Nm = Fn_GetFileName(stA67FullNm)   'Set the Public Variable
    Debug.Print "    A67Setup", , Format((Timer - t), "#0.#00"), stA67FullNm
End Sub
Sub DepconProcess()
'------------------------------------------------------------------------------------
'Enter with the following public variables set
'Public stCoCNewYearPath As String   'New 2005+ CoC Overview Report from HQ
'Public iCoCNewYear As Integer       'Most Recent CoC Overview File from HQ
'Public stCoCName As String          'CoC filename from Sub SetOfficeNm(082605E)
'Public stCoCPath As String
'Public iCoCYear As Integer          'Most Recent Year in Master Office File
'Public iCoCOfficeYear As Integer    'DEBUG VARIABLE - CLEAN THIS UP 121005
'Public blCoCReports As Boolean      'True if COC Overview files exist in Depcon
'Public blCoCUpdated As Boolean      'CoC Update flag from Sub CoCStatus(082605E)
'Public blAbort As Boolean
'
'------------------------------------------------------------------------------------
    Dim t As Single
    t = Timer
 
    Debug.Print "  Call DepconProcess()"
    Call DelWorkFiles
    Call A67Concatenate
    fmProgress.pcProgress (20)
    Call A67ParseMonthlyReport
    Call Parse_LOCCSAll 'MAIN LOOP - Parse the master text file as a tab-delimited file for EXCEL
    fmProgress.pcProgress (30)
    Call Format_LOCCSAll        'Input and format the tab-delimited text file
    fmProgress.pcProgress (50)
    Call CoCUpdate              'Execute only if iCoCYear = 0
    Call CoCNewYear             'Append a new Overview Report to the Master Overview report
    Call CoCCopy                'Execute only if there is an Overview report to append
    fmProgress.pcProgress (70)
    Call CoCMerge               'Execute only if there is an Overview report to append
    Call CoCDeleteDuplicates    'Execute only if there is an Overview report to append
    fmProgress.pcProgress (80)
    Call StartDateReplace
    Call ColorCells2
    Call Subtotals
    Call A67_SetColumns
    Call A67OfficeUpdate
    Call A67Save
    Call DelWorkFiles
    Debug.Print "  DepconProcess", , Format((Timer - t), "#0.#00")
    'Debug.Print 2, dtDepconDate, dtA67xlsDate, stA67Nm, stDepConFileNm
End Sub
Sub CopyTextBox()
'
'   Public stTextBoxNm AS String
'   Public stbutton As String
'
    Dim i As Long
    Dim stTextboxRow As String
    Dim t As Single
    t = Timer
 
    fmProgress.pcProgress (50)
 
    Select Case iButtonNmbr
        Case 1:     stTextBoxNm = "Text Box 2"  'In use
        Case 2:     stTextBoxNm = "Text Box 33" 'In use
        Case 3:     stTextBoxNm = "Text Box 38"
        Case 4:     stTextBoxNm = "TextBox 27"
        'Case 5:     stTextBoxNm = "Text Box 40"
        'Case 6:     stTextBoxNm = "Text Box 40"
        Case 8:     stTextBoxNm = "Text Box 32" 'In use
        Case 9:     stTextBoxNm = "Text Box 41"
        'Case 10:    stTextBoxNm = "Text Box 35"
        'Case 11:    stTextBoxNm = "Text Box 35"
        Case 12:    stTextBoxNm = "Text Box 34"
        'Case 13:    stTextBoxNm = "Text Box 36"
        'Case 14:    stTextBoxNm = "Text Box 36"
        'Case 15:    stTextBoxNm = "Text Box 36"
        'Case 16:    stTextBoxNm = "Text Box 36"
        Case 17:    stTextBoxNm = "Text Box 36" 'In use
        Case 18:    stTextBoxNm = "Text Box 44" 'In use
        'Case 19:    stTextBoxNm = "Text Box 42"
        'Case 20:    stTextBoxNm = "Text Box 43"
        Case 22:    stTextBoxNm = "Text Box 58" 'In use by "Grants that do not have Site Control"
        Case 23:    stTextBoxNm = "Text Box 59"
        Case Else
            stTextBoxNm = ""
    End Select
    If stTextBoxNm = "" Then
        'Exit Sub
    Else
        Application.ScreenUpdating = False
        wkb1.Activate
        Worksheets("Criteria").Activate
        ActiveSheet.Shapes(stTextBoxNm).Select
        Selection.Copy
        Worksheets("MACROS").Activate
        Application.ScreenUpdating = False
        wkb3.Activate
        Range("A1").Select
        i = Range(ActiveCell, ActiveCell.End(xlDown)).Rows.Count
        If i > 65000 Then i = 5     'For filters that return "zero" rows
        Cells(i + 5, 1).Select
        ActiveSheet.Paste
        'Application.ScreenUpdating = True
    End If
    fmProgress.pcProgress (65)
    Debug.Print "CopyTextBox", , Format(Timer - t, "#0.#00"); "  Database Tab Instructions - "; stTextBoxNm
End Sub
Sub BossnapsOpen()
'
    Dim t As Single
'-------------------------------------------------------------------------------------
'DP A67 CoC CoCU NewDP   CONDITION - ACTION TAKEN
'0   0   X   X   X   NO Depcon + NO A67 Files - ABORT
'0   1   X   X   X   NO Depcon +  A67 Report - Use A67 Report
'1   0   0   X   X   Depcon + NO CoCReport - Abort
'1   0   1   X   X   Depcon Files + No A67 + CoCReport - Generate new A67
'1   1   0   X   X   Depcon Files + A67 Report + NO Overview Report - Use A67
'X   X   1   0   X   Depcon Files + A67 + CoCReport + NOT CoCUpdated - Generate new A67
'X   X   X   1   0   NO NewDepconFIles - Use A67 Report
'X   X   X   1   1   NewDepconFiles - Generate new A67
'-------------------------------------------------------------------------------------
    t = Timer
    Debug.Print "Call BossnapsOpen()", , "Activate when BOSSNAPS opened, A67R1 Creation/Activation"
    Call BossnapsSetup
 
   If Not blDepConDir And Not blA67Reports Then                        '0   0   X   X   X
        stMsg = " No DEPCON folder " + Chr(10) + "No A67 reports in BOSSNAPS folder."
    ElseIf Not blDepConFiles And Not blA67Reports Then
        stMsg = "There are reports in the DEPCON folder but none of them" + Chr(13) _
                + " are valid CPD (A67B2CC) reports."
    ElseIf Not blDepConFiles And blA67Reports Then                        '0   1   X   X   X
        Call A67Select
    ElseIf blDepConFiles And Not blA67Reports And Not blCoCReports Then  '1   0   0   X   X
        stMsg = "Depcon files but no CoC Overview Report - Abort"
    ElseIf blDepConFiles And Not blA67Reports And blCoCReports Then      '1   0   1   X   X
        Call DepconProcess
        stMsg = "Generated A67 Report " + stA67FullNm + " from Depcon files"
    ElseIf blDepConFiles And blA67Reports And Not blCoCReports Then      '1   1   0   X   X
        Call A67Select
    ElseIf blCoCReports And Not blCoCUpdated Then                        'X   X   1   0   X
        Call DepconProcess
        stMsg = "Overview report updated and used to create a new A67 report from Depcon files"
    ElseIf blCoCUpdated And Not blNewDepcon Then                        'X   X   X   1   0
        Call A67Select
    ElseIf blCoCUpdated And blNewDepcon Then                            'X   X   X   1   1
        Call DepconProcess
        stMsg = "Used DEPCON files to create new report " + Chr(10) + stA67FullNm _
        + Chr(10) + Chr(10) + "SELECT ANY BUTTON"
    End If
    fmProgress.pcProgress (90)
    Workbooks(stMacroNm).Worksheets("MACROS").Activate
    Call Format_ErrorWindow(stMsg)
    fmProgress.Hide
    Debug.Print "BossnapsOpen", , Format((Timer - t), "#0.#00"), "TOTAL RUN TIME"
    MsgBox (stMsg)
End Sub
Sub BeforeClose_Bossnaps()
 
    Dim wkb As Workbook
 
    ActiveWorkbook.Save
    If wkb2 Is Nothing Then
        For Each wkb In Workbooks
            If InStr(1, wkb.Name, "A67_R1.") > 0 Then
                Set wkb2 = wkb                              'Set Public Variable Wkb2
                stMacroNm = wkb2.Name
                stMacroDir = ThisWorkbook.Path
                stA67Nm = wkb2.Name
                Workbooks(stA67Nm).Close
 
            End If
        Next wkb
    End If
End Sub
Sub ColorCells2()       'Edit 061405
 
    Dim Rng As Range
    Dim stData As String
    Dim t As Single
    Dim i As Long
 
    t = Timer
 
    Application.ScreenUpdating = False
    Range("A1").CurrentRegion.Name = "A67data"
    Set Rng = Range("A67data")
    For i = 1 To Rng.Rows.Count
        'Debug.Print rngDates(i, 9).Value
        If Rng(i, 9).Value = "No Data" Then Rng(i, 9).Font.ColorIndex = 3
        If Rng(i, 10).Value = "No Data" Then Rng(i, 10).Font.ColorIndex = 3
        If Rng(i, 11).Value = "No Data" Then Rng(i, 11).Font.ColorIndex = 3
    Next i
    Debug.Print "    ColorCells2", Format((Timer - t), "#0.#00"), "Color all 'No Data' Cells red"
End Sub
Sub LOCCS_ALLPageSetup()
    Dim t As Single
    t = Timer
'    Application.ScreenUpdating = False
'    Columns("Y:DJ").Select
'    Selection.EntireColumn.Hidden = True
 
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        '.LeftHeader = ""
        .CenterHeader = "&""Arial,Bold""&14BOSSNAPS&12&Xplus"
        '.RightHeader = ""
        '.LeftFooter = ""
        .CenterFooter = "&P of &N"
        .RightFooter = "&F"
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(1)
        .BottomMargin = Application.InchesToPoints(1)
        .HeaderMargin = Application.InchesToPoints(0.5)
        .FooterMargin = Application.InchesToPoints(0.5)
        '.PrintHeadings = False
        .PrintGridlines = True
        '.PrintComments = xlPrintNoComments
        '.PrintQuality = 600
        .CenterHorizontally = True
        '.CenterVertically = False
        .Orientation = xlLandscape
        '.Draft = False
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        '.Order = xlDownThenOver
        '.BlackAndWhite = False
        '.Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 100
    End With
    Range("A1").Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Range("$A1").Select
    ActiveWindow.SplitRow = 1
    ActiveWindow.SplitColumn = 1
    ActiveWindow.FreezePanes = True
    Range("C1").Select
    Debug.Print "LOCCS_ALLPageSetup", , Format((Timer - t), "#0.#00")
End Sub
Sub CoCSetup()
'-------------------------------------------------------------------
'If J:\DEPCON\"COC_?????.xls" exists then append it to the A67 report
'that was created by SUB FormatLOCCSALL.
'-------------------------------------------------------------------
    Dim i As Long, j As Long, n As Long
    Dim wkb As Workbook
    Dim rgCOC As Range, rgA67 As Range
    Dim fs As Variant
    Dim lLastA67Row As Long
    Dim lLastCoCRow As Long
    Dim blCoC2004Text As Boolean
    Dim blCoC2004Xls As Boolean
    Dim bldebug As Boolean
    Dim stA67WkBk As String
    Dim t As Single
    t = Timer
 
    Application.ScreenUpdating = False
    Set wkb = Workbooks.Open(Filename:=stCoCPath)
    wkb.Worksheets("Sheet1").Activate
    Set rgCOC = Range("$A2").CurrentRegion
    Set wkb2 = Workbooks.Open(Filename:=stDepconFullNm & ".xls")
    Workbooks(wkb2.Name).Worksheets("LOCCS_ALL").Activate
    Set rgA67 = Range("$A1").CurrentRegion
    lLastCoCRow = rgCOC.Rows.Count
    lLastA67Row = rgA67.Rows.Count
    '----------------------------------------------------
    'Copy/Append the COC_2004.xls rows over to A67 report
    '----------------------------------------------------
For i = 1 To lLastCoCRow - 1
            j = lLastA67Row + i
        n = i + 1
        rgA67.Cells(j, 1).Value = rgCOC.Cells(n, 4)     'LOCCS_Project#
        rgA67.Cells(j, 3).Value = rgCOC.Cells(n, 17)    'Year
        rgA67.Cells(j, 4).Value = rgCOC.Cells(n, 15)    'State
        rgA67.Cells(j, 5).Value = rgCOC.Cells(n, 18)    'Program
        rgA67.Cells(j, 6).Value = rgCOC.Cells(n, 8)     'CoC Applicant Name
        rgA67.Cells(j, 7).Value = "Not in LOCCS-From CoC Overview Report"   'GRANTEE_TID
        rgA67.Cells(j, 10).Value = rgCOC.Cells(n, 6)    'LOCCS_Term
        rgA67.Cells(j, 14).Value = rgCOC.Cells(n, 12)   'LOCCS Authorized
        rgA67.Cells(j, 15).Value = 0                    'LOCCS Disbursed
        rgA67.Cells(j, 16).Value = rgCOC.Cells(n, 12)   'LOCCS Balance
        rgA67.Cells(j, 17).Value = dtRptDate            'LOCC_RPTDATE
        rgA67.Cells(j, 18).Value = rgCOC.Cells(n, 19)   'BLICODES
        If rgCOC.Cells(n, 20).Value = "CANCELLED" Then  'Test "Status" field ':121905
            rgA67.Cells(j, 23).Value = "FALSE"          'Cancelled Grant
        Else
            rgA67.Cells(j, 23).Value = "TRUE"           'ActiveGrant
        End If
        rgA67.Cells(j, 24).Value = rgCOC.Cells(n, 3)   'CoC Continuum Name ':123106
        rgA67.Cells(j, 25).Value = rgCOC.Cells(n, 1)    'CoCPID
        rgA67.Cells(j, 26).Value = rgCOC.Cells(n, 5)    'CoCProgram Code
        rgA67.Cells(j, 27).Value = rgCOC.Cells(n, 7)    'CoCComponent
        rgA67.Cells(j, 28).Value = rgCOC.Cells(n, 6)    'CoC Term
        rgA67.Cells(j, 29).Value = rgCOC.Cells(n, 8)    'CoC Applicant Name
        rgA67.Cells(j, 30).Value = rgCOC.Cells(n, 9)    'CoC Sponsor
        rgA67.Cells(j, 31).Value = rgCOC.Cells(n, 10)   'CoC Project Name
        rgA67.Cells(j, 32).Value = rgCOC.Cells(n, 12)   'CoC Award
        rgA67.Cells(j, 33).Value = rgCOC.Cells(n, 16)   'CoC Continuum Name
        rgA67.Cells(j, 34).Value = rgCOC.Cells(n, 20)   'Status
        rgA67.Cells(j, 35).Value = rgCOC.Cells(n, 13)   'Rep
        rgA67.Cells(j, 36).Value = rgCOC.Cells(n, 21)   'User1
        rgA67.Cells(j, 37).Value = rgCOC.Cells(n, 22)   'User2
        rgA67.Cells(j, 38).Value = rgCOC.Cells(n, 23)   'User3
    Next i
 
    With rgA67
        .Resize(.Rows.Count + lLastCoCRow).Name = "Database"
    End With
    '---------------------------------------------------------------------------
    'Sort the A67 report so that all duplicate project numbers will be together
    'for CoC_Merge subroutine
    '---------------------------------------------------------------------------
    'Application.ScreenUpdating = False
 
    Range("$A1").CurrentRegion.Select
    Selection.Sort Key1:=Range("$A2"), Order1:=xlAscending, Key2:=Range("$A2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom
    ActiveWorkbook.Save
    Workbooks(Wkb4.Name).Close SaveChanges:=True
    wkb.Close
    Workbooks(wkb2.Name).Activate
    Debug.Print "CoCSetup", , Format(Timer - t, "#0.#00")
End Sub
Sub CoCMerge()
'-------------------------------------------------------------------------------------
'090426 Change for EXCEL 2007 Speed problem. Using Array vs Worksheet Cells
'Enter with A67 Report(Wkb2) containing the Depcon data and the Overview data
'Call only when creating a new DEPCON report. Execute only when "CoC2004.xls"
'has been created/appended to new A67 Report. The new LOCCS A67 record with an Overview
'duplicate must be updated with the CoC data then the CoC duplicate is deleted
'-------------------------------------------------------------------------------------
    Dim vA67Term As Variant
    Dim vCoCTerm As Variant
    Dim rgDB As Range, rgMyRange As Range
    Dim i As Long, j As Long, k As Long
    Dim lRows As Long, lRwCoC As Long, lColCoC As Long
    Dim mystuff As Variant
    Dim CurrentProject As Variant, NextProject As Variant
    Dim rgFoundCell As Range
    Dim wkb As Workbook
    Dim fs As Variant
    Dim t As Single
    Dim stStatus As String
    Dim vaCoCMerge As Variant
 
    If blAbort Then Exit Sub
    If Not blCoCReports Then
        Debug.Print "CoCMerge         -No CoC Overview Reports to process - EXIT"
        Exit Sub
    End If
    t = Timer
    'Call SetWkbObjects
 
    Application.ScreenUpdating = False
    If wkb2 Is Nothing Then
        Set wkb2 = Workbooks.Open(Filename:=stA67FullNm)
    End If
        Workbooks(wkb2.Name).Worksheets("LOCCS_ALL").Activate
    With ActiveSheet
        .UsedRange  'Reset the last cell
        Set rgDB = Range("$A1").CurrentRegion
        rgDB.Select
        '----------------Sort so that duplicates are grouped---------------------
        Selection.Sort Key1:=Range("$A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        .UsedRange
        vaCoCMerge = rgDB.CurrentRegion
    End With
    Debug.Print "CoCMerge rgdb.Rows.Count = " & rgDB.Rows.Count
    For i = 1 To rgDB.Rows.Count - 1
        CurrentProject = vaCoCMerge(i, 1)
        NextProject = vaCoCMerge(i + 1, 1)
        If CurrentProject = "LOCCS_Nmbr" Then   ':100725 Changed "Project Number" to "LOCCS_Nmbr"
                                            'This is the header row for CoC_Office table
            vaCoCMerge(i, 13) = True        'Flag CoC_Office table headerrecord for deletion
        ElseIf (CurrentProject = NextProject) And (vaCoCMerge(i, 2) = "") _
                And (vaCoCMerge(i + 1, 2) = "") Then
            '-----------------------------------------------------------------------------
            'BOTH RECORDS HAVE THE SAME PROJECT NUMBER AND BOTH ARE NOT IN LOCCS(has EMPTY LOCCS_NMBR1)
            'Duplicate LOCCS record found. Select the empty record and mark it for deletion
            '-----------------------------------------------------------------------------
                If vaCoCMerge(i, 14) = 0 Then   '
                    vaCoCMerge(i, 13) = True          'Flag record for deletion
                ElseIf vaCoCMerge(i + 1, 14) = 0 Then
                    vaCoCMerge(i + 1, 13) = "TRUE"      'Flag record for deletion
                Else
                'two copies of the same bkp file delete the first
                     vaCoCMerge(i + 1, 13) = "TRUE"      'Flag record for deletion
                End If
        ElseIf CurrentProject = NextProject Then
                '--------------------------------------------------------------------------
                'THERE ARE TWO RECORDS WITH THE SAME PROJECT NUMBER.ONE IN A67 LOCCS TABLE
                'AND THE OTHER IN THE COC_OFFICE TABLE
                'YOUR ARE MAPPING COC_OFFICE rows TO A67 rows BEFORE REFORMAT OF A67
                'Copy the duplicate record (Overview) to the LOCCS Record then
                'flag the duplicate record(overview) for deletions
                '-------------------------------------------------------------------------
                vaCoCMerge(i, 3) = vaCoCMerge(i + 1, 3)   'Year :100802 This sets the A67 Funding Year to CoC Year & replaces Year value
                                                          'This will only happen for a project in LOCCS with a matching CoC project
                vaCoCMerge(i, 24) = vaCoCMerge(i + 1, 24) 'CoCCode
                vaCoCMerge(i, 25) = vaCoCMerge(i + 1, 25) 'PIN
                vaCoCMerge(i, 26) = vaCoCMerge(i + 1, 26) 'CoCProgram Code
                vaCoCMerge(i, 27) = vaCoCMerge(i + 1, 27) 'CoCComponent
                vaCoCMerge(i, 28) = vaCoCMerge(i + 1, 28) 'CoC Term
                vaCoCMerge(i, 29) = vaCoCMerge(i + 1, 29) 'CoC Applicant Name
                vaCoCMerge(i, 30) = vaCoCMerge(i + 1, 30) 'CoC Sponsor
                vaCoCMerge(i, 31) = vaCoCMerge(i + 1, 31) 'CoC Project Name
                vaCoCMerge(i, 32) = vaCoCMerge(i + 1, 32) 'CoC Award
                vaCoCMerge(i, 33) = vaCoCMerge(i + 1, 33) 'CoC Continuum Name
                vaCoCMerge(i, 34) = vaCoCMerge(i + 1, 34) 'Status
                vaCoCMerge(i, 35) = vaCoCMerge(i + 1, 35) 'Rep
                vaCoCMerge(i, 36) = vaCoCMerge(i + 1, 36) 'User1
                vaCoCMerge(i, 37) = vaCoCMerge(i + 1, 37) 'User2
                vaCoCMerge(i, 38) = vaCoCMerge(i + 1, 38) 'User3
                vaCoCMerge(i + 1, 13) = "TRUE"            'Flag record for deletion
                '-----------------------------------------------------------------------
                ':051206 If there is Term data in the Coc file and the a67 term field is
                'empty, copy the CoC term data to the A67 record.  This will update S+C
                'records with user input
                '-----------------------------------------------------------------------
                vA67Term = vaCoCMerge(i, 10)
                vCoCTerm = vaCoCMerge(i + 1, 10)
                If vA67Term = "No Data" And vCoCTerm > 0 Then vaCoCMerge(i, 10) = vCoCTerm
        ElseIf CurrentProject <> NextProject Then
        '-----------------------------------------------------------------------------
        'YOU ARE HERE BECAUSE THE Current Record <> NEXT RECORD:
        '(1) - A RECORD IN LOCCS WITH A DIFFERENT PROJECT # OR
        '(2) - A COC_OFFICE RECORD WITH A DIFFERENT PROJECT #
        'If RECORD = TYPE 2 AND is two or more Years old then set Field Status = ":Cancel"
        '-----------------------------------------------------------------------------
            If Not (IsEmpty(vaCoCMerge(i + 1, 2))) Then
                'Debug.Print vaCoCMerge(i, 1), vaCoCMerge(i + 1, 1), vaCoCMerge(i + 1, 7), vaCoCMerge(i, 34), i
            ElseIf vaCoCMerge(i + 1, 1) = "Project Number" Then
                vaCoCMerge(i + 1, 13) = True
            Else
                iRptYear = Year(vaCoCMerge(i + 1, 17))
                iYear = vaCoCMerge(i + 1, 3)
                stStatus = vaCoCMerge(i + 1, 34)
                If (iRptYear - iYear > 2) Then vaCoCMerge(i + 1, 34) = stStatus + ":Cancel"
                'Debug.Print vaCoCMerge(i, 1), vaCoCMerge(i + 1, 1), vaCoCMerge(i + 1, 7), vaCoCMerge(i + 1, 34), i
            End If
        End If
    Next i
    rgDB = vaCoCMerge
    Debug.Print "    CoCMerge", , Format((Timer - t), "#0.#00"), "Update A67 with CoC Data & MARK duplicates"
End Sub
Sub WkbksInit()
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim fs As Variant
    Dim icount As Long
    Dim i As Long
 
    Call SetDepconDir   'Set PV "stDepconDir" to DEPCON Directory Path
    Call SetOfficeNm    'Set PV "stCoCPath" to Overview File Name Path
    Set wkb = Workbooks(stCoCPath)
    If wkb Is Nothing Then
        Workbooks.Open (stCoCPath)
    End If
'---------------------------------------------------------
'Set the workbook object variables for all open workbooks
'---------------------------------------------------------
    For Each wkb In Workbooks
        If InStr(1, wkb.Name, "A67.") = 0 Then
            Set wkb2 = wkb                              'Set Public Variable Wkb2
            stA67Nm = wkb2.Name
        ElseIf InStr(1, wkb.Name, "BOSSNAPS") = 1 Then
            Set wkb1 = wkb                              'Set Public Variable Wkb1
            stMacroNm = wkb1.Name
            stMacroDir = ThisWorkbook.Path
        ElseIf InStr(1, wkb.Name, "CoC_") = 1 Then
            Set Wkb4 = wkb                              'Set Public Variable Wkb4
            stWkb4Name = Wkb4.Name                 'Set up the Public Variable
        End If
    Next wkb
'-----------------------------------------------------------------------------
'Test to see if the CoC Report has already been integrated into the A67 report
'-----------------------------------------------------------------------------
    wkb2.Activate
    Worksheets("LOCCS_ALL").Activate
    icount = Range("$A1").CurrentRegion.Rows.Count
    blCoCIntegrated = False
    For i = 1 To icount
        If IsEmpty(Range("Database").Cells(i, 2).Value) Then
            blCoCIntegrated = True
            Exit For
        End If
    Next i
End Sub
Sub CoCText()
 
 
    Const ForReading = 1, ForWriting = 2, ForAppending = 3
    Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
 
    Dim i As Long, j As Long, x As Long, y As Long
    Dim wkb As Workbook
    Dim fs As Variant, f As Variant
    Dim blCoC2004Text As Boolean
    Dim blCoC2004Xls As Boolean
    Dim bldebug As Boolean
    Dim stA67WkBk As String
    Dim MyFile, MyPath, MyName
    Dim CoCNmbr As String
    Dim Status As String
    Dim EOR As Boolean
    Dim Outbuf As String
    Dim stTerm As String
    Dim iTerm As Long
 
    Dim CocFields(1, 12)
    Dim NumField As Long
    Dim ANStart As Long
    Dim ANEnd As Long
    Dim ANLines As Long
    Dim State As String
    Dim Project As String
    Dim w As Workbook
    Dim RW As String
    Dim lr As Long
    Dim CoCStart As String, CoCTitle As String, CoCName As String
 
'--------------------------------------------
'Check to see if files "CoC_2004.xls" or "CoC_2004.txt" exists in DEPCON directory
'--------------------------------------------
    Set fs = CreateObject("Scripting.FileSystemObject")
    If (fs.FileExists(stDEPCONDir & "\COC_2004.txt")) Then blCoC2004Text = True
    If (fs.FileExists(stDEPCONDir & "\COC_2004.xls")) Then blCoC2004Xls = True
    If blCoC2004Text = False And blCoC2004Xls = False Then Exit Sub
    If blCoC2004Xls = True Then Exit Sub
'--------------------------------------------------------------------
'File "COC_200.xls" does not exist and file "COC_2004.txt" does exist
'Create file "COC_2004.xls" from "CoC_2004.txt"
'---------------------------------------------------------------------
    CocFields(0, 0) = "Project#"
    CocFields(0, 1) = "PID"
    CocFields(0, 2) = "PGM CODE"
    CocFields(0, 3) = "TERM"
    CocFields(0, 4) = "COMP"
    CocFields(0, 5) = "APPLICANT NAME"
    CocFields(0, 6) = "PROJECT NAME"
    CocFields(0, 7) = "SPONSOR"
    CocFields(0, 8) = "STATUS"
    CocFields(0, 9) = "SCORE"
    CocFields(0, 10) = "AWARD"
    CocFields(0, 11) = "CONTINUUM"
    CocFields(0, 12) = "Rep"
    BosnapDir = ThisWorkbook.Path + "\"
    BosnapNm = ThisWorkbook.Name
 
    ChDir stDEPCONDir
'----------------------------------------------------------------------------
'Open a file for final output called CoC_ALL.txt
'----------------------------------------------------------------------------
    Set fs = CreateObject("Scripting.FileSystemObject")
    If (fs.FileExists("CoC_ALL.txt")) Then
       Kill "CoC_ALL.txt"
    End If
    fs.CreateTextFile ("CoC_ALL.txt")          'Create a text stream file system object
    Set f = fs.getfile("CoC_ALL.txt")     'Create a new output file
    Set tsout = f.OpenAsTextStream(ForWriting, TristateUseDefault)
    For i = 0 To 12
        Outbuf = Outbuf + CocFields(0, i) + Chr(9)
    Next i
    tsout.Writeline (Outbuf)
'----------------------------------------------------------------------------
'Open the Input data file
'----------------------------------------------------------------------------
    Set f = fs.getfile(stDEPCONDir + "\CoC_2004.txt")
    Set tsin = f.OpenAsTextStream(ForReading, TristateUseDefault) 'Open an input file
'----------------------------------------------------------------------------
'Main Loop - Process all CoC Report records until EOF
'----------------------------------------------------------------------------
 
    Do While tsin.AtEndOfStream <> True
 
        '----------------------------------------------------------------------------
        'Find the start of a CoC Report Record/ CoC Name
        '----------------------------------------------------------------------------
        CoCLineBuf(0) = tsin.ReadLine
        'Debug.Print CoCLineBuf(0)
        Project = Mid(CoCLineBuf(0), 5, 2)
        If Project = "-5" Then
            '----------------------------------------------------------------------------
            'This could be start of a record or start of a Continuum Name.
            'If Continuum Name then set CoCName variable and continue looking
            'for start of record
            '----------------------------------------------------------------------------
            If Project = "-5" Then
                CoCNmbr = Mid(CoCLineBuf(0), 1, 8)
                CoCTitle = Trim(Mid(tsin.ReadLine, 1, 50))
                CoCName = CoCNmbr & ":" & CoCTitle
                'Debug.Print CoCName
            End If
        ElseIf Project = "B4" Or Project = "C4" Or Project = "K4" Then
            '----------------------------------------------------------------------------
            'Start of a record found - read until end of record marker "$"
            '----------------------------------------------------------------------------
                i = 1
                Do While tsin.AtEndOfStream <> True
                    CoCLineBuf(i) = tsin.ReadLine
                    If Mid(CoCLineBuf(i), 1, 1) = "$" Then
                        CoCLineBuf(i + 1) = Mid(tsin.ReadLine, 1)
                        i = i + 1   'Have "i" point to the last field in the record
                        Exit Do     'Exit with "i" pointing to last field in the CoC record
                    End If
                i = i + 1
                Loop
                '----------------------------------------------------------------------------
                'Complete Record in CoCLineBuf()- Process the record
                '----------------------------------------------------------------------------
                CocFields(1, 0) = CoCLineBuf(0)     '"Project#" is always the first field
                iTerm = CInt(CoCLineBuf(i))         '"TERM" is always the last field
                CocFields(1, 3) = CStr(iTerm * 12)  '"TERM" is always the last field
                CocFields(1, 12) = ""               'New Rep field
                State = Mid(CoCLineBuf(i - 3), 3, 4)
                '------------------------------------------------------------------------
                'If the PID is present it will always be in this position relative to the last line
                '------------------------------------------------------------------------
                If IsNumeric(State) Then
                    CocFields(1, 1) = Mid(CoCLineBuf(i - 3), 1) '"PID"
                Else
                    CocFields(1, 1) = ""
                End If
                '------------------------------------------------------------------------
                'These fields are always in this position relative to the last field in record (Score)
                '------------------------------------------------------------------------
                CocFields(1, 9) = CoCLineBuf(i - 2)  '"SCORE"
                CocFields(1, 10) = CoCLineBuf(i - 1)  '"AWARD"
                CocFields(1, 11) = CoCName
'                CocFields(1, 11) = Mid(CocFields(1, 0), 1, 2) + Mid(CocFields(1, 0), 7, 2) '"CONTINUUM #"
                '------------------------------------------------------------------------
                'Find the first numeric line in the record - this is always the CoC score
                '------------------------------------------------------------------------
                For x = 0 To 125
                    '------------------------------------------------------------------------
                    'These fields are always in this position relative to the CoC score
                    '------------------------------------------------------------------------
                    If IsNumeric(Mid(CoCLineBuf(x), 1)) Then
                        CocFields(1, 2) = CoCLineBuf(x + 1)  '"PGM CODE"
                        CocFields(1, 8) = CoCLineBuf(x + 2)  '"STATUS"
                        CocFields(1, 4) = CoCLineBuf(x + 3)  '"COMP"
                        CocFields(1, 5) = CoCLineBuf(x + 4)  '"APPLICANT NAME"
                       Exit For
                    End If
                Next x
                '------------------------------------------------------------------------
                'Enter here with the following field position markers available:
                ' i = last field (Term)
                ' x = first numeric field (Score)
                ' i-3 = CocFields(1,1), "PID" with data if it exists or blank if it does not
                '------------------------------------------------------------------------
 
                '--------------------------------------------------
                'Calculate the "SPONSOR" and "PROJECT NAME" fields
                '--------------------------------------------------
                If x = 2 Then
                '------------------------------------------------------------------
                'If there is only one line after project ID then it is Project Name
                '------------------------------------------------------------------
                    CocFields(1, 7) = CoCLineBuf(x - 1)    '"PROJECT NAME"
                    CocFields(1, 6) = " "                  '"SPONSOR"
                Else
                    '------------------------------------------------------------------------
                    'More than one text line after Project#. Since Project Name will always
                    ' exists, assume line 1 as "PROJECT NAME" and last line pointer as "SPONSOR"
                    '------------------------------------------------------------------------
                    CocFields(1, 7) = CoCLineBuf(1)    '"PROJECT NAME"
                    CocFields(1, 6) = CoCLineBuf(x - 1)  '"SPONSOR"
                End If
 
                '------------------------------------------------------------------
                'Get all lines that compose "APPLICANT NAME"
                '------------------------------------------------------------------
                ANStart = x + 4     'This is always the start of the "APPLICANT NAME" field
                If CocFields(1, 1) = "" Then
                    ANEnd = i - 3   'End of "APPLICANT NAME" field if PID is blank
                Else
                    ANEnd = i - 4   'End of "APPLICANT NAME" field if PID is not blank
                End If
                ANLines = ANEnd - ANStart
                CocFields(1, 5) = ""
                For y = 0 To ANLines
                    CocFields(1, 5) = CocFields(1, 5) + CoCLineBuf(ANStart + y)
                Next y
                '------------------------------------------------------------------
                'A complete record is now in the CocFields(1,x) buffer. Write out
                'the record to file CoC_All.xls
                '------------------------------------------------------------------
                Outbuf = ""
                Status = CocFields(1, 8)
 
                If (Status = "D") Or (Status = "R") Or (Status = "N") Then
                    For x = 1 To 125    'Clear the output line buffer
                        CoCLineBuf(x) = ""
                    Next x
                Else
                    For x = 0 To 12     'Write out a line
                    Outbuf = Outbuf + CocFields(1, x) + Chr(9)
                    Next x
                    tsout.Writeline (Outbuf)
                    For x = 1 To 125    'Clear the output line buffer
                        CoCLineBuf(x) = ""
                    Next x
                End If
        End If
    Loop
 
    tsin.Close
    tsout.Close
    'If this Macro is run on same file without closing last file - clean up files.
        For Each w In Workbooks
    If w.Name <> ThisWorkbook.Name Then
        w.Close SaveChanges:=True
    End If
    Next w
'Open the temporary Text file and convert it from a tab-delimited file to an EXCEL worksheet
    Application.ScreenUpdating = False
    Workbooks.OpenText Filename:="CoC_ALL.txt", Origin:=xlWindows, _
    StartRow:=1, DataType:=xlDelimited, Tab:=True
    Range("A1").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    RW = Trim(Str(Selection.Rows.Count))
    lr = RW + 2
    ActiveSheet.Range(Cells(lr, 1), Cells(lr, 1)).Formula = "=SubTotal(3,A2:A" + RW + ")"
    ActiveSheet.Range(Cells(lr, 10), Cells(lr, 10)).Formula = "=Subtotal(9,J2:J" + RW + ")"
'Format the Output Data Table
    Rows("1:1").Select
    Selection.Font.Bold = True
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    ActiveWindow.SplitRow = 1
    ActiveWindow.SplitColumn = 1
    ActiveWindow.FreezePanes = True
    Columns("A:A").Select
    Selection.Columns.AutoFit
    Columns("C:E").Select
    Selection.ColumnWidth = 6
    Selection.HorizontalAlignment = xlCenter
    Columns("E:E").Select
    Selection.ColumnWidth = 6
    Columns("F:F").Select
    Selection.ColumnWidth = 20
    Columns("K:K").Select
    Selection.NumberFormat = "$#,##0"
    Selection.Columns.AutoFit
    Columns("J:J").Select
    Selection.NumberFormat = "0"
    Columns("G:H").Select
    Selection.ColumnWidth = 20
    Columns("I:J").Select
    Selection.ColumnWidth = 4
    Selection.HorizontalAlignment = xlCenter
    Range("A1").Select
    Selection.AutoFilter
 
    Set fs = CreateObject("Scripting.FileSystemObject")
    If (fs.FileExists("CoC_2004.xls")) Then
       Kill "CoC_2004.xls"
    End If
    ActiveSheet.Range("B2").Select
 
    ActiveWorkbook.SaveAs Filename:=stDEPCONDir + "\CoC_2004.xls", FileFormat:=xlNormal
End Sub
Sub CoCDeleteDuplicates()
 
    Dim fs As Variant
    Dim lLastRow As Long
    Dim stFindZZZ As String
    Dim stFoundCell As String
    Dim Rng As Range
    Dim rgFoundCell As Range
    Dim wkb As Workbook
    Dim t As Single
 
    If blAbort Then Exit Sub
    If Not blCoCReports Then Exit Sub
 
    t = Timer
    Application.ScreenUpdating = False
    Workbooks(wkb2.Name).Worksheets("LOCCS_All").Activate
    'Worksheets("LOCCS_All").Activate
    With ActiveSheet
        .UsedRange
        '-----------Sort the database so the "ZZZ" records are grouped at end -----------
        Range("$A1").CurrentRegion.Select
        Selection.Sort Key1:=Range("$M1"), Order1:=xlAscending, Key2:=Range("$M1") _
            , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
            False, Orientation:=xlTopToBottom
        Set Rng = Range("M1", Range("M1").End(xlDown))
        stFindZZZ = Rng.Address
        '------------Find the first "ZZZ" record ---------------------------------
        Set rgFoundCell = Range(stFindZZZ).Find(what:="TRUE")
        stFoundCell = rgFoundCell.Address
        '-------------------------------------------------------------------------------
        'Define a single range object that has all "ZZZ" records then delete the records
        '-------------------------------------------------------------------------------
        Range(stFoundCell, Range("M1").End(xlDown)).EntireRow.Delete
        .UsedRange
    End With
    Debug.Print "    CoCDeleteDuplicates", Format(Timer - t, "#0.#00"), "Delete all marked records"
End Sub
Sub StartDateReplace()
    Dim wkb As Workbook
    Dim t As Single
    t = Timer
 
    If wkb2 Is Nothing Then
        For Each wkb In Workbooks
            If InStr(1, wkb.Name, "A67R1.") > 0 Then
                Set wkb2 = wkb                              'Set Public Variable Wkb2
                stMacroNm = wkb2.Name
                stMacroDir = ThisWorkbook.Path
                stA67Nm = wkb2.Name
            End If
        Next wkb
    End If
    Application.ScreenUpdating = False
    Workbooks(wkb2.Name).Worksheets("LOCCS_All").Activate
'---------------------------------------------------------
'Replace the "1/1/100" strings used in the "Start_Date &
'"Exp_Date" fields for ACCESS with blanks that are OK for EXCEL
'---------------------------------------------------------
    Columns("I:I").Select
    Selection.Replace what:="1/1/100", Replacement:="No Data", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    Columns("K:K").Select
    Selection.Replace what:="1/1/100", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    Debug.Print "    StartDateReplace", Format((Timer - t), "#0.#00"), "Replace all '1/1/100' Access null dates with blanks"
End Sub
Function Fn_CoCName(CoCID As String) As String
'-------------------------------------------------------------
'Convert the CoC Overview Report CoC ID to a string that can
'be used for all years.(i.e. MA04-501: to MA01:)
'MA04-501:Franklin/Hampden/Hamshire/Holyoke County CoC
'-------------------------------------------------------------
    Dim i As Integer
    Dim stCoCState As String
    Dim stCoCNmbr As String
    Dim stCoCName As String
 
    stCoCState = Mid(CoCID, 1, 2)
    i = InStr(1, CoCID, ":")
    If i = 0 Then Exit Function
    stCoCNmbr = Mid(CoCID, i - 2, 2)
    stCoCName = Trim(Mid(CoCID, i))
    Fn_CoCName = stCoCState & stCoCNmbr & stCoCName
End Function
Function Fn_CoCTag() As String
'-------------------------------------------------------------
'Convert the CoC Overview Report CoC ID to a string that can
'be used for all years.(i.e. MA04-501: to MA01:)
'MA04-501:Franklin/Hampden/Hamshire/Holyoke County CoC
'-------------------------------------------------------------
    Dim i As Integer
    Dim stCoCState As String
    Dim stCoCNmbr As String
 
    stCoCState = Mid(stGrantName, 1, 2)
    If Len(stGrantName) < 15 Then          ':090429 Fix for new 2008 grant names
        stCoCNmbr = Mid(stGrantName, 7, 2)
    Else
        stCoCNmbr = Mid(stGrantName, 10, 2)
    End If
    Fn_CoCTag = stCoCState & stCoCNmbr
End Function
Sub HighlightRows()
 
 
    Dim wkb As Workbook, wkb3 As Workbook
    Dim wks As Worksheet
    Dim icount As Long
    Dim Flag As Integer
    Dim rgDB As Range, rgMyRange As Range
    Dim i As Long, j As Long, k As Long
    Dim t As Single
    t = Timer
 
    Application.ScreenUpdating = False
    Call SetWkbObjects
    Set rgMyRange = Range("$A1").CurrentRegion
    ActiveWorkbook.Names.Add Name:="MyDatabase", RefersToR1C1:=rgMyRange
    With Range("MyDatabase")
        If .Rows.Count = 1 Then
         Set rgDB = .Offset(1, 0).Resize(.Rows.Count)
        Else
         Set rgDB = .Offset(1, 0).Resize(.Rows.Count - 1)
        End If
    End With
 
    Select Case iButtonNmbr
        Case 1 'SHP Renewal Verification"
            For i = 1 To rgDB.Rows.Count
                dtExpDate = rgDB3.Cells(i, 16).Value
                If IsDate(dtExpDate) Then
                    If Month(dtExpDate) = 12 And Day(dtExpDate) = 31 Then   ':090827 Fix for exp date of 12/31/nn or 12/31nn-1
                        If Year(dtExpDate) = iExpYear - 1 Then
                            rgDB.Cells(i, 13).EntireRow.Interior.ColorIndex = 6
                        End If
                    End If
                End If
            Next i
        Case 3  'Expired Balance.SPC"
            For i = 1 To rgDB.Rows.Count
                Flag = rgDB.Cells(i, 18).Value
                If (Flag = 0) Then rgDB.Cells(i, 13).EntireRow.Interior.ColorIndex = 6
            Next i
        Case 2      'Expiring Grants.SPC"
            For i = 1 To rgDB.Rows.Count
                Flag = rgDB.Cells(i, 18).Value
                If (Flag > 2) Then rgDB.Cells(i, 18).EntireRow.Interior.ColorIndex = 6
            Next i
         Case 22      'SHP Grant needing site control
            For i = 1 To rgDB.Rows.Count
                Flag = rgDB.Cells(i, 18).Value
                If (Flag > 4) Then rgDB.Cells(i, 18).EntireRow.Interior.ColorIndex = 6
            Next i
         Case 23      'SHP Grant with restrictive covenant not completed
            For i = 1 To rgDB.Rows.Count
                Flag = rgDB.Cells(i, 18).Value
                If (Flag > 4) Then rgDB.Cells(i, 18).EntireRow.Interior.ColorIndex = 6
            Next i
       Case Else
    End Select
Sub_Exit:
    fmProgress.pcProgress (47)
    Debug.Print "HighlightRows", , Format(Timer - t, "#0.#00"); "  ****NEEDS TO BE INTEGRATED"
End Sub
Sub FilterA67()
'   Public stbutton As String
    Dim wkb As Workbook
    Dim Rng As Range
    Dim rgCriteria As Range
    Dim rgCopy As Range
    Dim rgA67 As Range
    Dim rgDestination As Range
    Dim stCriteria As String
    Dim iptr As Integer
    Dim stLastRow As String
    Dim irows As Long
    Dim stRptDate As String
    Dim t As Single
 
    Application.ScreenUpdating = False
    t = Timer
    'stbutton = "RPT3-Grantee Count"    'Set the Public Variable for test purposes only
    Call SetWkbObjects
    Select Case iButtonNmbr
        Case 1:     stCriteria = "A44:G47"  'Grants Eligible for Renewal.SHP ':091001
            Set rgCopy = Workbooks(wkb2.Name).Worksheets("LOCCS_ALL").Range("A1").CurrentRegion
            With rgCopy
                .Range(Cells(1, 42), Cells(1, 50)).EntireColumn.Hidden = False 'BLI-Acq/Rehab/NC
                .Cells(1, 57).EntireColumn.Hidden = False     'BLI-Operations
                .Cells(1, 63).EntireColumn.Hidden = False     'BLI-SS
                .Cells(1, 66).EntireColumn.Hidden = False     'BLI-HMIS
                .Cells(1, 69).EntireColumn.Hidden = False     'BLI-ADMIN
                .Cells(1, 81).EntireColumn.Hidden = False     'BLI-LEASE
                .Cells(1, 82).EntireColumn.Hidden = False     'Use for Annual Renewal Verification
                .Cells(1, 83).EntireColumn.Hidden = False     'Use for Annual Renewal Verification
            End With
        Case 2:     stCriteria = "F33:H36"  'Grants Eligible for Renewal.SPC
        Case 4:     stCriteria = "O16:P18" 'Expired Balance for SHP/SPC/YB/HPAC
        'Case 3:     stCriteria = "N10:Q11"  'Expired Balance.SPC
        'Case 4:     stCriteria = "I10:K11"  'Expired Balance.SHP
        'Case 5:     stCriteria = "S1:V2"    'Expired Balance.YB
        'Case 6:     stCriteria = "X1:AA2"   'Expired Balance.HPAC
        Case 7:     stCriteria = ""         'Not Used
        Case 8:     stCriteria = "R33:S37"  'Problem Spenders.ALL  012106
        Case 9:     stCriteria = "C16:D17"  'Problem Spenders.SPC
        Case 10:    stCriteria = "E16:F17"  'Problem Spenders.YB
        Case 11:    stCriteria = "G16:H17"  'Problem Spenders.HPAC
        Case 12:    stCriteria = "A21:C22"  'Restrictive Covenants.SHP
        Case 13:    stCriteria = "I1:L4"    'Active Grants.ALL
        Case 14:    stCriteria = "N1:Q4"    'Active Grants.SPC
        Case 15:    stCriteria = "S1:V2"    'Active Grants.YB
        Case 16:    stCriteria = "X1:AA2"   'Active Grants.HPAC
        Case 17:    'stCriteria = "AG1:AH2"  'Active Grants.ALL
                    Set rgCriteria = ThisWorkbook.Worksheets("Criteria").Range("AK1:AK2")
                    With rgCriteria
                        .Cells(1, 1) = "Balance"
                        .Cells(2, 1) = ">0"
                        '.Cells(3, 1) = ""
                        '.Cells(1, 2) = "Start_Date"
                        '.Cells(2, 2) = ""
                        '.Cells(3, 2) = "No Data"
                    End With
                    stCriteria = "AK1:AK2"  'List of all grants with a balance > 0
        Case 18:    stCriteria = "R33:S37" 'Problem Grtants
        Case 19:    stCriteria = "L33:M35"  'Grants Not Defined to LOCCS
        Case 20 '---Grantee Count with Grant Count and Sum of Authorized for each Grantee -----
                    Set rgCriteria = ThisWorkbook.Worksheets("Criteria").Range("AK1:AK2")
                    With rgCriteria
                        .Cells(1, 1) = "Balance"
                        .Cells(2, 1) = ">0"
                    End With
                    stCriteria = "AK1:AK2"  'Grantee Count
        Case 21:    stCriteria = "L33:M35"  'Grants-Potential Loss of Funding This Sept
        Case 22:    stCriteria = "B39:C40"  'SHP Grants Needing Site Control
        Case 23:    stCriteria = "B39:C40"  'SHP grants Needing Restrictive Covenants
   End Select
    Application.ScreenUpdating = False
    Set rgCopy = Workbooks(wkb2.Name).Worksheets("LOCCS_ALL").Range("A1").CurrentRegion
    Set rgDestination = Workbooks(wkb3.Name).Worksheets("Sheet1").Range("A1")
    With rgCopy
        .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
            Workbooks(wkb1.Name).Sheets("Criteria").Range(stCriteria), Unique:=False
        rgCopy.SpecialCells(xlCellTypeVisible).Copy (Workbooks(wkb3.Name).Worksheets("Sheet1").Range("A1"))
    End With
    Workbooks(wkb3.Name).Worksheets("Sheet1").Activate
    stLastRow = Range("A1").End(xlDown).Address
    'ThisWorkbook.Worksheets("MACROS").Activate
    Debug.Print "FilterA67", , Format(Timer - t, "#0.#00"); "  rows = "; stLastRow
End Sub
Sub SetWkbObjects()
'---------------------------------------------------------
'Set the workbook object variables for all open workbooks
'Wkb3 is identified by the wkb3.name initialized by Sub SetButtonsArray
'---------------------------------------------------------
    'Public Wkb1 As Workbook            'The BOSMAC Workbook object
    'Public Wkb2 As Workbook            'The A67*.xls Workbook object
    'Public wkb3 As Workbook            'The "Filtered" Workbook object
    'Public Wkb4 As Workbook            'The "CoC_2004.xls" Workbook object
    'Public stWkb3Name As String        'Name of "Filtered" Workbook to be saved
    'Public stMacroFullNm As String     'The Full Pathname string for the BOSMAC MACRO workbook
    'Public stCoCFullNm as string       'Full Patname for COC_????.XLS Overview Report
    'Public stMacroNm As String         'The Filename string for the BOSMAC MACRO workbook
    'Public stMacroDir As String        'The Directory Path Name string for the BOSMAC MACRO workbook
    'Public stA67Nm As String           'The Filename string for the A67*.xls workbook
    Dim wkb As Workbook
    Dim stCriteria As String
    Dim iptr As Integer
    Dim stRptDate As String
    Dim stRptYear As String
    Dim t As Single
 
    t = Timer
    If vButtonsArray(0, 1) = "" Then Call SetButtonsArray  ':021306
    For Each wkb In Workbooks
        If InStr(1, wkb.Name, "A67R1.") > 0 Then
            Set wkb2 = wkb                              'Set Public Variable Wkb2
            stMacroNm = wkb2.Name
            stMacroDir = ThisWorkbook.Path
            stA67Nm = wkb2.Name
            stA67WkbName = wkb2.Name
            iptr = InStr(1, wkb2.Name, ".xls")
            stRptDate = Mid(wkb2.Name, iptr - 8, 8)
            stRptYear = Mid(stRptDate, 5, 4)
            iRptYear = CInt(stRptYear)  '--------Create Report Year PV from A67 File Name
            iExpYear = CInt(stRptYear) + 1
            stWkb3Name = vButtonsArray(0, iButtonNmbr) & "." & stRptDate & ".xls"   '070504 button array edit
        ElseIf InStr(1, wkb.Name, "BOSSNAPS") > 0 Then
            Set wkb1 = wkb                              'Set Public Variable Wkb1
            stMacroDir = ThisWorkbook.Path
        ElseIf InStr(1, wkb.Name, "CoC_") > 0 Then
            Set Wkb4 = wkb
            stCoCPath = Workbooks(wkb.Name).FullName
        ElseIf InStr(1, wkb.Name, vButtonsArray(0, iButtonNmbr)) > 0 Then
            Set wkb3 = wkb
            stWkb3Name = wkb.Name
        End If
    Next wkb
    If wkb2 Is Nothing Then
        iAbort = 6
    End If
    'Debug.Print "   SetWkbObjects", , Format((Timer - t), "#0.#00"),
End Sub
Sub ExpBalSPC()
 
    Dim i As Long, j As Long, k As Long
    Dim rgMyRange As Range
    Dim rgDB As Range
 
    Dim Term As Long
    Dim MonthsElapsed As String
    Dim Flag As Integer
    Dim PctSpent As Double
    Dim Balance As Currency
 
    Call SetWkbObjects
 
 
    If wkb3 Is Nothing Then MsgBox ("Error in Subroutine ButtonFilters - ABORT")
    Application.ScreenUpdating = False
    Workbooks(wkb3.Name).Sheets("Sheet1").Activate
    Set rgMyRange = Range("$A1").CurrentRegion
    ActiveWorkbook.Names.Add Name:="Database", RefersToR1C1:=rgMyRange
    With Range("Database")
        If .Rows.Count = 1 Then
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count)
        Else
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count - 1)
        End If
    End With
 
    For i = 1 To rgDB.Rows.Count
        rgDB.Cells(i, 13).Value = 0
    Next i
 
    For i = 1 To rgDB.Rows.Count
        If (IsNumeric(rgDB.Cells(i, 10).Value)) Then
            Term = rgDB.Cells(i, 10).Value
        Else
            Term = 0
        End If
 
        If Not (IsNumeric(rgDB.Cells(i, 12).Value)) Then
            MonthsElapsed = 0
 
        Else
            MonthsElapsed = rgDB.Cells(i, 12).Value
        End If
 
        Balance = rgDB.Cells(i, 16).Value
        PctSpent = rgDB.Cells(i, 20).Value
        '--------------------------------------------------------
        'Enter here with Balance > 0
        'Use "Activity" field(12) as a temporary flag field
        'A negative value means grant is probably not expired
        'A zero or positive value means grant is probably expired
        'A zero value is an unknown and will be highlighted
        '---------------------------------------------------------
        If Not (IsNumeric(MonthsElapsed)) Then
            rgDB.Cells(i, 13).Value = -3    'New Grant not defined to LOCCS
        ElseIf MonthsElapsed < 13 Then
            rgDB.Cells(i, 13).Value = -1
        ElseIf PctSpent > 0.95 Then
            rgDB.Cells(i, 13).Value = 1
        ElseIf (MonthsElapsed > 12) And (MonthsElapsed < 24) And (PctSpent > 0.4) Then
            rgDB.Cells(i, 13).Value = 2
        ElseIf (MonthsElapsed > 24) And (MonthsElapsed < 60) And (PctSpent < 0.72) Then
            rgDB.Cells(i, 13).Value = -2
        ElseIf PctSpent < 0.6 Then
            rgDB.Cells(i, 13).Value = -4
        End If
    Next i
End Sub
Sub Pass2Filter()
'   Public stbutton As String
'
    Dim wkb As Workbook
    Dim stCriteria As String
    Dim iptr As Integer
    Dim stRptDate As String
    Dim t As Single
 
    Debug.Print "Pass2Filter", , "       Select next major subroutine"
    t = Timer
    Call SetWkbObjects
'---------------------------------------------------------
 
    Select Case iButtonNmbr
        'Case 1:         Call ExpGrantSHP
        Case 1:         Call B01_SHPRenewals
        Case 2:         Call ExpGrantSPC
        Case 4:         Call B03_ExpwithBal
        'Case 3:         Call ExpBalSPC
        Case 8:         Call B08_SlowSpenderAll     ':012106
        Case 9:         Call SlowSpenderSPC
        Case 10:        Call SlowSpenderYB_HOPWA
        Case 11:        Call SlowSpenderYB_HOPWA
        Case 12:        Debug.Print "   B12:None Needed"
        Case 17:        Call B17_CancelGrant
        Case 18:        Call B18_ProblemGrants
        Case 19:        Call B19_NotinLOCCS         ':052006
        Case 20:        'Call B20_GranteeCount       ':052006
        Case 21:        Call B21_LoseFunding        ':052006
        Case 22:        Call B22_NoSiteControl      ':012106
        Case 23:        Call B23_NoResCovenant      ':012106
    End Select
    fmProgress.pcProgress (45)
    'Debug.Print "Pass2Filter", , Format(Timer - t, "#0.#00")
End Sub
 
Sub DeleteRows()
'   Public stbutton As String
'
    Dim wkb As Workbook
    Dim stCriteria As String
    Dim lLastRow As Long
    Dim stColumn As String, strow As String
    Dim Rng As Range
    Dim t As Single
    t = Timer
    'Column "R1" is the "Activity"field used to identify records to be deleted
    Application.ScreenUpdating = False
    Select Case iButtonNmbr
        Case 1:         stColumn = "R1": stCriteria = "<1"   ':012306
        Case 2:         stColumn = "R1": stCriteria = "<1"
        Case 3 To 6:    stColumn = "R1": stCriteria = "2"   ':012106
        Case 8:         stColumn = "R1": stCriteria = "2"   ':012106
        Case 9:         stColumn = "R1": stCriteria = "<1"
        Case 10:        stColumn = "R1": stCriteria = "<1"
        Case 11:        stColumn = "R1": stCriteria = "<1"
        Case 17:        stColumn = "R1": stCriteria = "2"   ':041406
        Case 18:        stColumn = "R1": stCriteria = "2"   ':012106
        Case 19:        stColumn = "R1": stCriteria = "<4"  ':052006
        Case 20:        stColumn = "R1": stCriteria = "<2"  ':052006
        Case 21:        stColumn = "R1": stCriteria = "<4"  ':052006
        Case 22:        stColumn = "R1": stCriteria = "2"   ':012106
        Case 23:        stColumn = "R1": stCriteria = "2"   ':012106
    End Select
 
    If stCriteria = "" Then GoTo Sub_Exit:
 
    Application.ScreenUpdating = False
    strow = Mid(stColumn, 1, 1)
    Rows(1).Insert
    Range("R1").Value = "Temp"
    With ActiveSheet
        .UsedRange
        lLastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
        Set Rng = Range(stColumn, Cells(lLastRow, strow))
        Rng.AutoFilter Field:=1, Criteria1:=stCriteria
        Rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .UsedRange
    End With
Sub_Exit:
    fmProgress.pcProgress (60)
    Debug.Print "DeleteRows", , Format(Timer - t, "#0.#00"); "  Delete Pass2 Filter rows based on 'Activity' field criteria"
End Sub
Sub NationalCoC()
Dim OfficeCodes(40, 2)
End Sub
Sub SetDepconDir()  ':090814 Fix for new BOSSNAPS for HQ
    'Object.FolderExists (folderspec)
 
 
    Dim stBosDir As String
    Dim fs As Variant
    Dim t As Single
    Dim i As Single
    Dim stHQDir As String
    Dim blBosHQ As Boolean
    Dim stBosName As String
    t = Timer
 
    stBosName = ThisWorkbook.Name
    If InStr(1, stBosName, "HQ") Then blBosHQ = True
    Select Case blBosHQ
 
        Case Is = True
            '---This path is for HQ Desk Officers-----
            'Check that this copy of BOSSNAPS is in a valid HQ DEPCON Folder
 
            Call SetHQDirs
            stBosDir = LCase(ThisWorkbook.Path) ':090419 Fix for string match
            For i = 1 To 43 ':090813 Fix for DEPCON HQ Folders
                stHQDir = LCase("J:\DEPCON\" & stHQDirs(i)) ':090419 Fix for String Match
                If stBosDir = stHQDir Then
                    stDEPCONDir = stBosDir
                    Debug.Print "    SetDepcondir", Format((Timer - t), "#0.#00"), stDEPCONDir
                    blDepConDir = True
                    Exit Sub
                End If
            Next i
            '----Bossnaps is not located in a valid HQ Folder
            '----Check to see if BOSSNAPS is in a Paquin Debug folder
            For i = 1 To 43 ':090813 Fix for DEPCON HQ Folders
                stHQDir = LCase("C:\DEPCON\" & stHQDirs(i))
                If stBosDir = stHQDir Then
                    stDEPCONDir = stBosDir
                    Debug.Print "    SetDepcondir", Format((Timer - t), "#0.#00"), stDEPCONDir
                    blDepConDir = True
            MsgBox ("BOSSNAPS is not in a HQ DEPCON Folder but is in a C:\DEPCON Field Office Folder")
                    Exit Sub
                End If
            Next i
            MsgBox ("BOSSNAPS is not in a HQ DEPCON Folder")
        Case Is = False
            blDepConDir = True
            Set fs = CreateObject("Scripting.FileSystemObject")
            If fs.folderexists("C:\C-Mystuff\DEPCON") Then
                stDEPCONDir = "C:\C-Mystuff\DEPCON"
            ElseIf fs.folderexists("K:\DEPCON") Then
                stDEPCONDir = "K:\DEPCON"
            ElseIf fs.folderexists("J:\DEPCON") Then
                stDEPCONDir = "J:\DEPCON"
            ElseIf fs.folderexists("J:\CPD\DEPCON") Then
                stDEPCONDir = "J:\CPD\DEPCON"
            ElseIf fs.folderexists("Z:\DEPCON") Then
                stDEPCONDir = "Z:\DEPCON"
            ElseIf fs.folderexists("\\Nbosnfp002\cpd\DEPCON") Then
                stDEPCONDir = "\\Nbosnfp002\cpd\DEPCON"
            Else
                blDepConDir = False
            End If
    End Select
    Debug.Print "    SetDepcondir", Format((Timer - t), "#0.#00"), stDEPCONDir
End Sub
Sub CPDOffice()
'Public stDEPCONDir As String
'Public stCPDOffice As String
 
    Call SetDepconDir
    Call SetCPDOffices
    Call SetOfficeNm
 
End Sub
Sub SetCPDOffices()
 
    stCPDOffices(0, 1) = "Philadelphia"
    stCPDOffices(0, 2) = "Connecticut"
    stCPDOffices(0, 3) = "New Hampshire"
    stCPDOffices(0, 4) = "New York"
    stCPDOffices(0, 5) = "Buffalo"
    stCPDOffices(0, 6) = "New Jersey"
    stCPDOffices(0, 7) = "Massachusetts"
    stCPDOffices(0, 8) = "Baltimore"
    stCPDOffices(0, 9) = "Pittsburgh"
    stCPDOffices(0, 10) = "Virginia"
    stCPDOffices(0, 11) = "DC"
    stCPDOffices(0, 12) = "Atlanta"
    stCPDOffices(0, 13) = "Alabama"
    stCPDOffices(0, 14) = "Miami"
    stCPDOffices(0, 15) = "South Carolina"
    stCPDOffices(0, 16) = "North Carolina"
    stCPDOffices(0, 17) = "Mississippi"
    stCPDOffices(0, 18) = "Jacksonville"
    stCPDOffices(0, 19) = "Kentucky"
    stCPDOffices(0, 20) = "Tennessee"
    stCPDOffices(0, 21) = "San Juan"
    stCPDOffices(0, 22) = "Chicago"
    stCPDOffices(0, 23) = "Ohio"
    stCPDOffices(0, 24) = "Michigan"
    stCPDOffices(0, 25) = "Indiana"
    stCPDOffices(0, 26) = "Wisconsin"
    stCPDOffices(0, 27) = "Minnesota"
    stCPDOffices(0, 28) = "Fort Worth"
    stCPDOffices(0, 29) = "New Mexico"
    stCPDOffices(0, 30) = "Arkansas"
    stCPDOffices(0, 31) = "Louisiana"
    stCPDOffices(0, 32) = "Oklahoma"
    stCPDOffices(0, 33) = "San Antonio"
    stCPDOffices(0, 34) = "Kansas City"
    stCPDOffices(0, 35) = "Omaha"
    stCPDOffices(0, 36) = "St. Louis"
    stCPDOffices(0, 37) = "Denver"
    stCPDOffices(0, 38) = "San Francisco"
    stCPDOffices(0, 39) = "Hawaii"
    stCPDOffices(0, 40) = "Los Angeles"
    stCPDOffices(0, 41) = "Arizona"
    stCPDOffices(0, 42) = "Seattle"
    stCPDOffices(0, 43) = "Alaska"
    stCPDOffices(0, 44) = "Oregon"
    stCPDOffices(0, 45) = "Houston"
End Sub
Sub SetHQDirs()    '090814 Set the HQ Field Office Names for HQ DEPCON folders
 
    stHQDirs(1) = "Hartford"
    stHQDirs(2) = "Boston"
    stHQDirs(3) = "Buffalo"
    stHQDirs(4) = "Newark"
    stHQDirs(5) = "New York"
    stHQDirs(6) = "Baltimore"
    stHQDirs(7) = "Pittsburgh"
    stHQDirs(8) = "Richmond"
    stHQDirs(9) = "Washington"
    stHQDirs(10) = "Philadelphia"
    stHQDirs(11) = "Atlanta"
    stHQDirs(12) = "Birmingham"
    stHQDirs(13) = "Miami"
    stHQDirs(14) = "Columbia"
    stHQDirs(15) = "Greensboro"
    stHQDirs(16) = "Jackson"
    stHQDirs(17) = "Jacksonville"
    stHQDirs(18) = "Louisville"
    stHQDirs(19) = "Knoxville"
    stHQDirs(20) = "San Juan"
    stHQDirs(21) = "Columbus"
    stHQDirs(22) = "Detroit"
    stHQDirs(23) = "Indianapolis"
    stHQDirs(24) = "Milwaukee"
    stHQDirs(25) = "Minneapolis"
    stHQDirs(26) = "Chicago"
    stHQDirs(27) = "Albuquerque"
    stHQDirs(28) = "Houston"
    stHQDirs(29) = "Little Rock"
    stHQDirs(30) = "New Orleans"
    stHQDirs(31) = "Oklahoma City"
    stHQDirs(32) = "San Antonio"
    stHQDirs(33) = "Fort Worth"
    stHQDirs(34) = "Omaha"
    stHQDirs(35) = "St. Louis"
    stHQDirs(36) = "Kansas City"
    stHQDirs(37) = "Denver"
    stHQDirs(38) = "Honolulu"
    stHQDirs(39) = "Los Angeles"
    stHQDirs(40) = "San Francisco"
    stHQDirs(41) = "Anchorage"
    stHQDirs(42) = "Portland"
    stHQDirs(43) = "Seattle"
 
End Sub
Sub CreateMasterCoC()                   'FIX:090301 to replace "Application.Filesearch
                                        'Fix:090510 to create a MasterCoC from Annual CoC
                                        'Fix:090902 to Create a Master Coc from multiple Annual CoC files
'------------------------------------------------------------------------------
'Called only by BOSSNAPSSETUP().  Will provide a new MasterCoC file only when
'there is no Master COC in DEPCON folder and one or more Annual CoC reports
'Exist in DEPCON folder
'------------------------------------------------------------------------------
    Dim fs As Variant
    Dim fs1 As Variant
    Dim f As Variant
    Dim f1 As Variant
    Dim fc As Variant
    Dim iStartNm As Integer
    Dim iStartYr As Integer
    Dim iEndNm As Integer
    Dim iLength As Integer
    Dim stFileSearch As String
    Dim t As Single
    Dim iCoC_ As Integer
    Dim iCoC20 As Integer
    Dim stNewYear As String
    Dim stNewCoC As String
    Dim stMasterCoC As String
    Dim stMasterNm As String
    Dim stYear As String
    Dim stName As String
    Dim WkBk As Workbook
    Dim WkBk1 As Workbook
    Dim WkBk2 As Workbook
    Dim stFileName As String
    Dim stCOC20nn() As String
    Dim i As Integer
    Dim Rng As Range
    Dim Rng1 As Range
    Dim vCOC() As Variant
    Dim stAddress1 As String
    Dim iLRow As Long
    Dim iLen As Long
 
    t = Timer
    '-------------USE FOR DEBUG ONLY assuming boston folder --------------------
    'stDEPCONDir = "C:\DEPCON\BOSTON"
    'stMasterNm = "CoC_Massachusetts.2008"
    'stMasterCoC = stDEPCONDir & "\" & stMasterNm
    'blDepConDir = True
    'ChDir (stDEPCONDir)
    'iCoC_ = 0
    'Set fs = CreateObject("Scripting.FileSystemObject")
    'If (fs.FileExists(stMasterCoC & ".xls")) Then
    '   For Each WkBk In Workbooks
    '        If WkBk.Name = stMasterNm Then
    '            Workbooks(stMasterNm).Close
    '        End If
    '    Next
    '    Kill (stMasterCoC & ".xls")
    'End If
    '----------------------------------------------------------------------------
    If blDepConDir = False Then Exit Sub   'Exit if there is no DEPCON Directory
    Set fs1 = CreateObject("Scripting.FileSystemObject")
    '-----------------------------------------------------
    'Find the latest version of the Master Overview report
    'Files are sorted so last one will be newest
    '-----------------------------------------------------
    stFileSearch = "CoC_*.20*.xls"
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(stDEPCONDir)
    Set fc = f.Files    'Create a list object of all Master CoC_ files in DEPCON Directory
    '----Search List is sorted so last name in list will be the newest annual overview report-----
    For Each f1 In fc                           'Test each file in list to see if "CoC_OffineName.xls" format
        If (f1.Name Like stFileSearch) Then
            iCoC20 = iCoC20 + 1
            stMasterCoC = f1.Path     'Create a full pathname to be compatible with original code
        End If
    Next
    '-----------------------------------------------------
    'Find the latest version of the Annual Overview report
    'Files are sorted so last one will be newest
    '-----------------------------------------------------
    stFileSearch = "CoC20##_*.xls"
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(stDEPCONDir)
    Set fc = f.Files    'Create a list object of all files in DEPCON Directory
    For Each f1 In fc                           'Test each file in list
        If (f1.Name Like stFileSearch) Then
            iCoC_ = iCoC_ + 1
            ReDim Preserve stCOC20nn(1 To iCoC_)
            stCOC20nn(iCoC_) = f1.Path
            stNewYear = f1.Path
            iStartNm = InStr(1, f1.Name, "CoC2") + 8
            iEndNm = InStr(1, f1.Name, ".xls")
            iLength = iEndNm - iStartNm
            stName = Mid(f1.Name, iStartNm, iLength)
            stYear = Mid(f1.Name, 4, 4)
            stFileName = "CoC_" & stName & "." & stYear & ".xls"
            If Len(stNewCoC) = 0 Then   'This is the first time thru loop
                stNewCoC = stDEPCONDir & "\" & stFileName
            '------------------------------------------------------------
            ':090930 Possible Fix for HQ Los Angeles CoC Master filename problem
            '------------------------------------------------------------
            Else
                iLen = Len(stNewCoC) - 7
                If stYear > Mid(stNewCoC, iLen, 4) Then 'Replace the CoC name if newer year(i.e 2008>2007)
                    stNewCoC = stDEPCONDir & "\" & stFileName
                End If
            End If
        End If
    Next
    '------------------------------------------------------------------------------------------
    'This code is only for the special case where there is no Master CoC file but one or more
    'Annual Files that will be used to create a Master CoC file.
    'Enter with file stnewcoc = most recent COC Annual file name
    'Enter with dynamic array stCOC20nn() containing all COC Annual File names
    '------------------------------------------------------------------------------------------
    If (iCoC20 = 0) And iCoC_ > 0 Then
        MsgBox ("You do not have a master CoC file but you do have one or more annual CoC files. " & _
        "BOSSNAPS will create  new Master CoC file  '" & stNewCoC)
        For i = 1 To UBound(stCOC20nn)  ':090831 Copy/Concatenate all Annual files to master coc file
            Set WkBk = Workbooks.Open(Filename:=stCOC20nn(i))
            If i = 1 Then   'Oldest Annual file becomes new "COC_office.20nn.xls" base file
                Set WkBk1 = WkBk
                WkBk1.SaveAs Filename:=stNewCoC
                Set Rng1 = Range("A1").CurrentRegion
                stAddress1 = "$A$" & CStr(Rng1.Rows.Count + 1)  '---Pointer to blank row at end of data
            Else    '---Each Annual Report must be copy/concatenated to new CoC master file base
                With ActiveWorkbook '---Copy this annual report to Array without header row
                    Set Rng = Range("$A$1").CurrentRegion
                    iLRow = Rng.Rows.Count
                    Set Rng = Range("$A$2").Resize(iLRow - 1, 23)   '---Omit the Header Row
                    vCOC() = Rng.Value  '---Copy the spreadsheet data area to an array
                    WkBk.Close
                End With
                Workbooks(WkBk1.Name).Activate  '---Append the Annual Report Array to Master CoC
                With ActiveWorkbook
                    Range(stAddress1).Resize(iLRow - 1, 23).Value = vCOC    '---RANGE & ARRAY MUST BE SAME SIZE
                    Set Rng1 = Range("A1").CurrentRegion    '---Get the new data area
                    stAddress1 = "$A$" & CStr(Rng1.Rows.Count + 1)  '---Update the end of data pointer
                End With
            End If
        Next i
        WkBk1.Close SaveChanges:=True
    End If
    Debug.Print "    CreateMasterCoC", Format((Timer - t), "#0.#00"), "iC0C_ = "; iCoC_; " iC0C20 = "; iCoC20, stNewYear
End Sub
Sub SetOfficeNm()                   'FIX:090301 to replace "Application.Filesearch
                                    'FIX:090510 to correct Indiana problem
'Public stCoCNewYearPath As String  'New 2005+ CoC Overview Report from HQ
'Public iCoCNewYear As Integer      'Most Recent CoC Overview File from HQ
'Public stCoCName As String         'CoC filename from Sub SetOfficeNm(082605E)
'Public iCoCYear As Integer         'Most Recent Year in Master Office File
'Public stDEPCONDir As String
'Public stCPDOffice As String
 
    Dim fs As Variant
    Dim fs1 As Variant
    Dim f As Variant
    Dim f1 As Variant
    Dim fc As Variant
    Dim vafilename As Variant
    Dim icount As Integer
    Dim i As Integer
    Dim iStartNm As Integer
    Dim iStartYr As Integer
    Dim iEndNm As Integer
    Dim iLength As Integer
    Dim stCoCReport As String
    Dim stFileSearch As String
    Dim s As String
    Dim stMacroDir As String
    Dim vaArray As Variant
    Dim k As Integer
    Dim t As Single
 
    t = Timer
    'Call SetDepconDir '-------------Debug only -------------
    If blDepConDir = False Then Exit Sub   'Exit if there is no DEPCON Directory
 
    Call SetCPDOffices  'Set the CPD Offices Array
    Set fs1 = CreateObject("Scripting.FileSystemObject")
    '------------------------------------------------------------------------------
    'Find the latest version of the Overview report. This sub will handle multiple
    'Overview reports and select only the highest revision. Possible Reports:
    'CoC_Massachusetts.xls
    'CoC_Massachusetts.2004.xls
    'CoC_Massachusetts.2005.xls
    'CoC_Massachusetts.2006.xls
    'CoC_Massachusetts.2007.xls
    'CoC_Massachusetts.2008.xls
    '------------------------------------------------------------------------------
    stFileSearch = "CoC_*.xls"
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(stDEPCONDir)
    Set fc = f.Files    'Create a list object of all files in DEPCON Directory
    ReDim vaArray(1)                            '------Clear the PRArray dimensions-----
 
    For Each f1 In fc                           'Test each file in list
        s = f1.Name                             'Get the filename
        If (s Like stFileSearch) Then
            s = stDEPCONDir & "\" & s     'Create a full pathname to be compatible with original code
            icount = icount + 1
            ReDim Preserve vaArray(icount)
            vaArray(icount) = s
        End If
    Next
    If icount = 0 Then
        blCoCReports = False
    Else
        blCoCReports = True
        '------------------------------------------
        'Overview Reports Exist - Possible Reports:
        'CoC_Massachusetts.xls
        'CoC_Massachusetts.2004.xls
        'CoC_Massachusetts.2005.xls
        'CoC_Massachusetts.2006.xls
        'CoC_Massachusetts.2007.xls
        'CoC_Massachusetts.2008.xls
        '------------------------------------------
    For i = 1 To UBound(vaArray)
        If InStr(1, vaArray(i), ".200") > 0 Then    '------CoC Rev with five new fields
            iStartNm = InStr(1, vaArray(i), "CoC_") + 4
            iStartYr = InStr(1, vaArray(i), ".200") + 1
            iEndNm = iStartYr - 1
            iCoCYear = CInt(Mid(vaArray(i), iStartYr, 4))   'Set PV iCoCYear
            iLength = iEndNm - iStartNm
        Else    '------CoC Rev without five new fields
                iStartNm = InStr(1, vaArray(i), "CoC_") + 4
                iEndNm = InStr(1, vaArray(i), ".xls")
                iCoCYear = 0        'This is CoC_Massachusetts.xls Overview Report
                iLength = iEndNm - iStartNm
        End If
        stCoCReport = Mid(vaArray(i), iStartNm, iLength)
        For k = 1 To iFOCnt     '---------- Office name must be in the Office Array
            If stCPDOffices(0, k) = stCoCReport Then
                stCPDOffice = stCoCReport   '--------------------Set PV stCPDOffice
                stCoCPath = vaArray(i)      '--------------------Set PV stCoCPath
                If iCoCYear = 0 Then        '--------------------Set PV stCocName
                    stCoCName = "COC_" & stCPDOffice & ".xls" '--Set PV stCocName
                Else
                    stCoCName = "COC_" & stCPDOffice & "." & iCoCYear & ".xls"
                End If
            Exit For
            End If
        Next k
    Next i
        If i = 46 Then MsgBox ("The CoC Overiew Report name is not a valid Office Name" _
         & vafilename)
    End If
    '---------Search for old format Coc files-------------
    stFileSearch = "CoC200*.xls"
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(stDEPCONDir)
    Set fc = f.Files    'Create a list object of all files in DEPCON Directory
    ReDim vaArray(1)                            '------Clear the PRArray dimensions-----
    icount = 0
    For Each f1 In fc                           'Test each file in list
        s = f1.Name                             'Get the filename
        If (s Like stFileSearch) Then
            s = stDEPCONDir & "\" & s     'Create a full pathname to be compatible with original code
            icount = icount + 1
            ReDim Preserve vaArray(icount)
            vaArray(icount) = s
        End If
    Next
        '------------------------------------------------------------------------------------
        'If there is more than one new overview report (i.e. Coc2005_Office & CoC2006_Office
        'then only the newest one will be selected because they are sorted
        '------------------------------------------------------------------------------------
        'NOTE: PV "iCoCNewYear" > 0 is the flag indicating a new Overview report needs to be
        'processed.
        '------------------------------------------------------------------------------------
    '------------------------------------------------------------------------------------
    'Search for new year Overview reports (Example: COC2005_Massachusetts.xls)
    '-------------------------------------------------------------------------------------
    For i = 1 To UBound(vaArray)
        If icount = 0 Then Exit For
        blCoCNewYear = True
        iStartNm = InStr(1, vaArray(i), "CoC20") + 8
        iEndNm = InStr(1, vaArray(i), ".xls")
        iLength = iEndNm - iStartNm
        iCoCNewYear = CInt(Mid(vaArray(i), iStartNm - 5, 4))    'Set PV iCoCMewYear
        stCoCReport = Mid(vaArray(i), iStartNm, iLength)
        For k = 1 To iFOCnt
            If stCPDOffices(0, k) = stCoCReport Then
                stCPDOffice = stCoCReport
                stCoCNewYearPath = vaArray(i)                   'Set PV stCoCNewYearPath
                stCoCName = "COC_" & stCPDOffice & ".xls"       '082605E Set PV stCocName
                Exit For
            End If
        Next k
    Next i
    If i = 46 Then MsgBox ("The CoC Report is not a valid Office Name")
    If iCoCYear = 0 Then blCoCUpdated = False
    If (iCoCYear > 0) And (iCoCNewYear = 0) Then blCoCUpdated = True
    If (iCoCYear > 0) And (iCoCNewYear = iCoCYear) Then blCoCUpdated = True
    If (iCoCYear > 0) And (iCoCNewYear > iCoCYear) Then blCoCUpdated = False
 
    Debug.Print "    SetOfficeNm", Format((Timer - t), "#0.#00"), stCoCPath; iCoCYear; iCoCNewYear _
    ; blCoCUpdated
End Sub
Sub SetOfficeNmOrig()
 
'Public stCoCNewYearPath As String  'New 2005+ CoC Overview Report from HQ
'Public iCoCNewYear As Integer      'Most Recent CoC Overview File from HQ
'Public stCoCName As String         'CoC filename from Sub SetOfficeNm(082605E)
'Public iCoCYear As Integer         'Most Recent Year in Master Office File
'Public stDEPCONDir As String
'Public stCPDOffice As String
 
    Dim fs As Office.FileSearch
    Dim fs1 As Variant
    Dim vafilename As Variant
    Dim icount As Integer
    Dim i As Integer
    Dim iStartNm As Integer
    Dim iStartYr As Integer
    Dim iEndNm As Integer
    Dim iLength As Integer
    Dim stCoCReport As String
    Dim t As Single
 
    t = Timer
    'Call SetDepconDir '-------------Debug only -------------
    If blDepConDir = False Then Exit Sub   'Exit if there is no DEPCON Directory
 
    Call SetCPDOffices  'Set the CPD Offices Array
    Set fs = Application.FileSearch
    Set fs1 = CreateObject("Scripting.FileSystemObject")
    '------------------------------------------------------------------------------
    'Find the latest version of the Overview report. This sub will handle multiple
    'Overview reports and select only the highest revision. Possible Reports:
    'CoC_Massachusetts.xls
    'CoC_Massachusetts.2004.xls
    'CoC_Massachusetts.2005.xls
    '------------------------------------------------------------------------------
    With fs
        .NewSearch
        .LookIn = stDEPCONDir
        .SearchSubFolders = False
        .Filetype = msoFileTypeAllFiles
        .Filename = "CoC_*.xls"
        icount = .Execute
        If icount = 0 Then
            blCoCReports = False
        Else
            blCoCReports = True
            '------------------------------------------
            'Overview Reports Exist - Possible Reports:
            'CoC_Massachusetts.xls
            'CoC_Massachusetts.2004.xls
            'CoC_Massachusetts.2005.xls
            '------------------------------------------
            For Each vafilename In .FoundFiles
                If InStr(1, vafilename, ".200") > 0 Then    '------CoC Rev with five new fields
                    iStartNm = InStr(1, vafilename, "CoC_") + 4
                    iStartYr = InStr(1, vafilename, ".200") + 1
                    iEndNm = iStartYr - 1
                    iCoCYear = CInt(Mid(vafilename, iStartYr, 4))   'Set PV iCoCYear
                    iLength = iEndNm - iStartNm
                Else    '------CoC Rev without five new fields
                    iStartNm = InStr(1, vafilename, "CoC_") + 4
                    iEndNm = InStr(1, vafilename, ".xls")
                    iCoCYear = 0        'This is CoC_Massachusetts.xls Overview Report
                    iLength = iEndNm - iStartNm
                End If
                stCoCReport = Mid(vafilename, iStartNm, iLength)
                For i = 1 To iFOCnt     '---------- Office name must be in the Office Array
                    If stCPDOffices(0, i) = stCoCReport Then
                        stCPDOffice = stCoCReport   '--------------------Set PV stCPDOffice
                        stCoCPath = vafilename      '--------------------Set PV stCoCPath
                        If iCoCYear = 0 Then        '--------------------Set PV stCocName
                            stCoCName = "COC_" & stCPDOffice & ".xls" '--Set PV stCocName
                        Else
                            stCoCName = "COC_" & stCPDOffice & "." & iCoCYear & ".xls"
                        End If
                    Exit For
                    End If
                Next i
            Next vafilename
            If i = 46 Then MsgBox ("The CoC Overiew Report name is not a valid Office Name" _
             & vafilename)
        End If
 
    End With
    '------------------------------------------------------------------------------------
    'Search for new year Overview reports (COC2005_Massachusetts.xls)
    '-------------------------------------------------------------------------------------
    With fs
        .NewSearch
        .LookIn = stDEPCONDir
        .SearchSubFolders = False
        .Filetype = msoFileTypeAllFiles
        .Filename = "CoC200*.xls"
        icount = .Execute
        '------------------------------------------------------------------------------------
        'If there is more than one new overview report (i.e. Coc2005_Office & CoC2006_Office
        'then only the newest one will be selected because they are sorted
        '------------------------------------------------------------------------------------
        'NOTE: PV "iCoCNewYear" > 0 is the flag indicating a new Overview report needs to be
        'processed.
        '------------------------------------------------------------------------------------
        For Each vafilename In .FoundFiles
            If icount = 0 Then Exit For
            blCoCNewYear = True
            iStartNm = InStr(1, vafilename, "CoC200") + 8
            iEndNm = InStr(1, vafilename, ".xls")
            iLength = iEndNm - iStartNm
            iCoCNewYear = CInt(Mid(vafilename, iStartNm - 5, 4))    'Set PV iCoCMewYear
            stCoCReport = Mid(vafilename, iStartNm, iLength)
            For i = 1 To iFOCnt
                If stCPDOffices(0, i) = stCoCReport Then
                    stCPDOffice = stCoCReport
                    stCoCNewYearPath = vafilename                   'Set PV stCoCNewYearPath
                    stCoCName = "COC_" & stCPDOffice & ".xls"       '082605E Set PV stCocName
                    Exit For
                End If
            Next i
        Next vafilename
            If i = 46 Then MsgBox ("The CoC Report is not a valid Office Name")
    End With
    If iCoCYear = 0 Then blCoCUpdated = False
    If (iCoCYear > 0) And (iCoCNewYear = 0) Then blCoCUpdated = True
    If (iCoCYear > 0) And (iCoCNewYear = iCoCYear) Then blCoCUpdated = True
    If (iCoCYear > 0) And (iCoCNewYear > iCoCYear) Then blCoCUpdated = False
 
    Debug.Print "    SetOfficeNm", Format((Timer - t), "#0.#00"), stCoCPath; iCoCYear; iCoCNewYear _
    ; blCoCUpdated
End Sub
Sub SlowSpenderSPC()
 
    Dim i As Long, j As Long, k As Long
    Dim rgMyRange As Range
    Dim rgDB As Range
 
 
    Dim iTerm As Long
    Dim MonthsElapsed As String
    Dim Flag As Integer
    Dim iGrantYear As Integer
    Dim iRptYear As Integer
    Dim PctSpent As Double
    Dim PctTermExp As Double
    Dim Balance As Currency
    Dim blPRAW As Boolean
    Dim stTaxID
    Dim bNotinLOCCS As Boolean
 
    Call SetWkbObjects
 
 
    If wkb3 Is Nothing Then MsgBox ("Error in Subroutine ButtonFilters - ABORT")
    Application.ScreenUpdating = False
    Workbooks(wkb3.Name).Sheets("Sheet1").Activate
    Set rgMyRange = Range("$A1").CurrentRegion
    ActiveWorkbook.Names.Add Name:="Database", RefersToR1C1:=rgMyRange
    With Range("Database")
        If .Rows.Count = 1 Then
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count)
        Else
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count - 1)
        End If
    End With
    '---------------------------------------------------------------------
    'Calculate fields from internal data contained in CoC Overview report
    'and place those values in the Pass2filter files
    '---------------------------------------------------------------------
    For i = 1 To rgDB.Rows.Count
        bNotinLOCCS = False
        blPRAW = False
        rgDB.Cells(i, 13).Value = 0         'Clear the flag field
        If IsNumeric(rgDB.Cells(i, 3).Value) Then iGrantYear = rgDB.Cells(i, 3).Value
        If IsDate(rgDB.Cells(i, 17).Value) Then iRptYear = Year(rgDB.Cells(i, 17))
        If InStr(1, rgDB.Cells(i, 18).Value, "PRAW") > 0 Then blPRAW = True
        If InStr(1, rgDB.Cells(i, 7).Value, "Not") > 0 Then bNotinLOCCS = True
        MonthsElapsed = rgDB.Cells(i, 12).Value
        If Not IsNumeric(MonthsElapsed) Then MonthsElapsed = 0
        PctSpent = rgDB.Cells(i, 20).Value
        '------------------------------
        'Estimate the term of the grant
        '------------------------------
        iTerm = 0
        If (MonthsElapsed > -1) And (MonthsElapsed < 31) And (PctSpent > 0.47) Then
            iTerm = 12
        ElseIf (MonthsElapsed > 1) And (MonthsElapsed < 12) And (PctSpent > 0.2) Then
            iTerm = 12
        Else
            iTerm = 60
        End If
        rgDB.Cells(i, 10).Value = iTerm
 
        If bNotinLOCCS = True Then
            rgDB.Cells(i, 13).Value = -1    'CoC record not defined to LOCCS
        ElseIf (blPRAW = True) Then
            rgDB.Cells(i, 10).Value = 120    'Term = 120 months for PRAW project
            If MonthsElapsed > 120 Then
                rgDB.Cells(i, 13).Value = -4    '10 Year Grant that has expired
            ElseIf (Abs(MonthsElapsed / 120 - PctSpent) > 0.25) Then
                rgDB.Cells(i, 13).Value = 4    '10 Year Grant exceeds 25% spending Threshold
            Else
                rgDB.Cells(i, 13).Value = -41    '10 Year Grant that meets 25% spending threshold
            End If
        ElseIf (MonthsElapsed > 2) And (PctSpent < 0.05) Then
            rgDB.Cells(i, 13).Value = 2    'Grant has no expenditures for 3 months
        ElseIf (MonthsElapsed < 4) Then
            rgDB.Cells(i, 13).Value = -21    'Grant is less than 3 months old
 
        ElseIf iTerm = 12 And MonthsElapsed > 12 Then
                rgDB.Cells(i, 13).Value = -22    'Expired 12 month grant
        ElseIf iTerm = 12 And MonthsElapsed < 13 Then
            If (Abs(MonthsElapsed / 12 - PctSpent) > 0.25) Then
                rgDB.Cells(i, 13).Value = 3    '1 Year Grant exceeds 25% spending Threshold
            Else
                rgDB.Cells(i, 13).Value = -31   '1 Year Grant that meets 25% spending threshold
            End If
 
        ElseIf iTerm = 60 And MonthsElapsed > 60 Then
                rgDB.Cells(i, 13).Value = -5    'Expired 60 month grant
        ElseIf iTerm = 60 And MonthsElapsed < 61 Then
            If (Abs(MonthsElapsed / 60 - PctSpent) > 0.25) Then
                rgDB.Cells(i, 13).Value = 5    '1 Year Grant exceeds 25% spending Threshold
            Else
                rgDB.Cells(i, 13).Value = -51   '1 Year Grant that meets 25% spending threshold
            End If
        End If
'        ElseIf (MonthsElapsed > -1) And (MonthsElapsed < 31) And (PctSpent > 0.47) Then
'            rgDB.Cells(i, 12).Value = -3    '1 Year Grant that has expired
'            rgDB.Cells(i, 9).Value = 12
'        End If
 '       ElseIf (MonthsElapsed < 13) And (PctSpent > 0.21) Then
 '           rgDB.Cells(i, 12).Value = -2    '1 Year Grant
 '       ElseIf (MonthsElapsed > 13) And (MonthsElapsed < 31) And (PctSpent > 0.5) Then
 '           rgDB.Cells(i, 12).Value = -3    '1 Year Grant that has expired
 
 
'    ElseIf (PctTermExp < 1) And (Abs(PctTermExp - PctAwardSpent) > 0.25) Then
'        Fn_SlowSpender = "True"
'        End If
    Next i
End Sub
Sub SlowSpenderSHP()
 
    Dim i As Long, j As Long, k As Long
    Dim rgMyRange As Range
    Dim rgDB As Range
 
    Dim stStartDate As String
    Dim stProjectNmbr As String
    Dim Term As Long
    Dim MonthsElapsed As String
    Dim Flag As Integer
    Dim PctAwardSpent As Double
    Dim PctTermExp As Double
    Dim Acq_NC_REH As String
    Dim BLICodes As String
    Dim Balance As Currency
    Dim stTaxID As String
    Dim Award As Double
    Dim iYear As Integer
    Dim iRptYear As Integer
    Dim vStartDate As Variant
 
    Call SetWkbObjects
 
    If wkb3 Is Nothing Then MsgBox ("Error in Subroutine ButtonFilters - ABORT")
    Application.ScreenUpdating = False
    Workbooks(wkb3.Name).Sheets("Sheet1").Activate
    Set rgMyRange = Range("$A1").CurrentRegion
    ActiveWorkbook.Names.Add Name:="Database", RefersToR1C1:=rgMyRange
    With Range("Database")
        If .Rows.Count = 1 Then
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count)
        Else
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count - 1)
        End If
    End With
 
    For i = 1 To rgDB.Rows.Count
        rgDB.Cells(i, 13).Value = 0
    Next i
 
    For i = 1 To rgDB.Rows.Count
        stProjectNmbr = rgDB.Cells(i, 1).Value
        stStartDate = rgDB.Cells(i, 9).Value
        PctAwardSpent = rgDB.Cells(i, 20).Value
        PctTermExp = rgDB.Cells(i, 19).Value
        BLICodes = rgDB.Cells(i, 18).Value
        stTaxID = rgDB.Cells(i, 7).Value
        MonthsElapsed = rgDB.Cells(i, 12).Value
        If IsNumeric(rgDB.Cells(i, 3).Value) Then
            iYear = rgDB.Cells(i, 3).Value
        End If
        If IsDate(rgDB.Cells(i, 17).Value) Then
            iRptYear = Year(rgDB.Cells(i, 17))
        End If
 
        If (InStr(1, BLICodes, ",NC")) > 0 Then
            Acq_NC_REH = "True"
        ElseIf (InStr(1, BLICodes, ",ACQ")) > 0 Then
            Acq_NC_REH = "True"
        ElseIf (InStr(1, BLICodes, ",REH")) > 0 Then
            Acq_NC_REH = "True"
        Else
            Acq_NC_REH = "False"
        End If
  '-------------------------------------------
  ' Only analyze grants that have not expired with balances greater than 0
  '-------------------------------------------
        If (PctTermExp > 0.99) Then
            rgDB.Cells(i, 13).Value = -1
        ElseIf (PctAwardSpent > 0.995) Then
            rgDB.Cells(i, 13).Value = -2
 
  '------------------------------
  ' Grant is not defined to LOCCS
  '------------------------------
        ElseIf InStr(1, stTaxID, "Not in LOCCS") > 0 Then
            If (iRptYear - iYear = 1) Then
                rgDB.Cells(i, 13).Value = -3    'Not defined to LOCCS and less than 1 year old
            Else
                rgDB.Cells(i, 13).Value = 3     'Not defined to LOCCS and more than 1 year old
            End If
  '-------------------------------------------------
  ' Grant is  defined to LOCCS but has no start date
  '-------------------------------------------------
        ElseIf InStr(1, stStartDate, "No Data") > 0 Then
            If (iRptYear - iYear = 1) Then
                rgDB.Cells(i, 13).Value = -4   'Defined to LOCCS and less than 1 year old
            Else
                rgDB.Cells(i, 13).Value = 4     'Defined to LOCCS and more than 1 year old
            End If
  '-------------------------------------------------
  ' Grant is defined to LOCCS and has not expired - Test for a 25% difference
  '-------------------------------------------------
        ElseIf (PctTermExp < 1) And (PctTermExp - PctAwardSpent < 0.25) Then
            rgDB.Cells(i, 13).Value = -5
        ElseIf (PctTermExp < 1) And (PctTermExp - PctAwardSpent > 0.25) Then
            rgDB.Cells(i, 13).Value = 5
'-------------------------------------------------
' Grant is defined to LOCCS and has  expired
'-------------------------------------------------
'       ElseIf (PctTermExp > 0.99) And (PctAwardSpent < 0.97) Then
'            rgDB.Cells(i, 13).Value = 3
'        ElseIf (PctTermExp > 0.99) And (PctAwardSpent > 0.96) Then
'            rgDB.Cells(i, 13).Value = -4
'        ElseIf (PctTermExp > 0.2) And (PctAwardSpent = 0) Then
'           rgDB.Cells(i, 13).Value = 4
 '       ElseIf (PctTermExp < 1) And (Abs(PctTermExp - PctAwardSpent) > 0.25) And (Acq_NC_REH = "False") Then
 '           rgDB.Cells(i, 13).Value = 5
 '       ElseIf (PctTermExp < 1) And (Abs(PctTermExp - PctAwardSpent) < 0.25) And (Acq_NC_REH = "False") Then
 '           rgDB.Cells(i, 13).Value = -5
        End If
    Next i
End Sub
Sub ExpGrantSHP()
    'Public iExpYear As Integer          'Operator Input variable for Expiring Grant Year
    Dim i As Long, j As Long, k As Long
    Dim t As Single
 
    t = Timer
 
    Dim iTerm As Integer
    Dim iExpdtYear
    Dim dtExpDate As Date
    Dim rgMyRange As Range
    Dim rgDB As Range
    Dim stStartDate As String
    Dim stProjectNmbr As String
    Dim MonthsElapsed As String
    Dim Flag As Integer
    Dim PctAwardSpent As Double
    Dim PctTermExp As Double
    Dim BLICodes As String
    Dim Balance As Currency
    Dim stTaxID As String
    Dim Award As Double
    Dim iPrjYear As Integer
    Dim iRptYear As Integer
    Dim vStartDate As Variant
    Dim blNotinLOCCS As Boolean
    Dim blNoStartDate As Boolean
    Dim blRenewable As Boolean
 
    Call SetWkbObjects
 
    If wkb3 Is Nothing Then MsgBox ("Error in Subroutine ButtonFilters - ABORT")
    Application.ScreenUpdating = False
    Workbooks(wkb3.Name).Sheets("Sheet1").Activate
    Set rgMyRange = Range("$A1").CurrentRegion
    ActiveWorkbook.Names.Add Name:="Database", RefersToR1C1:=rgMyRange
    With Range("Database")
        If .Rows.Count = 1 Then
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count)
        Else
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count - 1)
        End If
    End With
    '------------------------------------
    'iExpYear = 2006    'FOR DEBUG ONLY
    '------------------------------------
    For i = 1 To rgDB.Rows.Count
        '-------------------------------------------------
        'Get the values of fields needed for this analysis
        '-------------------------------------------------
        rgDB.Cells(i, 18).Value = 0     'Clear "Activity" flag
        stProjectNmbr = rgDB.Cells(i, 1).Value
        BLICodes = rgDB.Cells(i, 19).Value
        PctAwardSpent = rgDB.Cells(i, 25).Value
        MonthsElapsed = rgDB.Cells(i, 17).Value
        stTaxID = rgDB.Cells(i, 12).Value
        If InStr(1, rgDB.Cells(i, 12).Value, "Not in LOCCS") > 0 Then
            blNotinLOCCS = True
        Else
            blNotinLOCCS = False
        End If
        If InStr(1, rgDB.Cells(i, 14).Value, "No Data") > 0 Then    'Test "StartDate"
            blNoStartDate = True
        Else
            blNoStartDate = False
        End If
        If IsNumeric(rgDB.Cells(i, 7).Value) Then   'Test "Year"
            iPrjYear = rgDB.Cells(i, 7).Value
        Else
            iPrjYear = 0
        End If
        dtExpDate = rgDB.Cells(i, 16).Value
       'debug.print rgDB.Cells(i, 16).Value, dtExpDate
        iTerm = rgDB.Cells(i, 15).Value
        If Not IsNumeric(iTerm) Then iTerm = 0
        BLICodes = rgDB.Cells(i, 19).Value
        If (InStr(1, BLICodes, ",SS")) > 0 Then
            blRenewable = True
        ElseIf (InStr(1, BLICodes, ",OPER")) > 0 Then
            blRenewable = True
        ElseIf (InStr(1, BLICodes, ",LEASE")) > 0 Then
            blRenewable = True
        ElseIf (InStr(1, BLICodes, ",HMIS")) > 0 Then
            blRenewable = True
        Else
            blRenewable = False
        End If
 
        '---------------------------------------------------------------------------------------
        'START THE SHP EXPIRED GRANT ANALYSIS
        '---------------------------------------------------------------------------------------
        If (Not blNotinLOCCS) And (Not blRenewable) Then
            rgDB.Cells(i, 18).Value = -62
            GoTo Nexti:
        End If
        If blNotinLOCCS = False Then
        '---------------------------
        'GRANT IS DEFINED TO LOCCS
        '--------------------------
            If IsDate(rgDB.Cells(i, 16).Value) Then     'Test "Expiration Date"
            '---------------------------------------------------
            'Grant is Defined to LOCCS and has a valid expiration date
            '---------------------------------------------------
                dtExpDate = DateAdd("d", 1, dtExpDate) 'Compensate for a 12/31/xx expiration date
                If Year(dtExpDate) = iExpYear Then
                    rgDB.Cells(i, 18).Value = 1    'Grant expiring in selected year
                Else
                    rgDB.Cells(i, 18).Value = -1
                End If
            ElseIf blNoStartDate Then
            '---------------------------------------------------
            'Grant is Defined to LOCCS but does not have a start
            'date but will always have term data
            '---------------------------------------------------
                If iPrjYear + 2 = iExpYear Then   'Most Recent Project Year
                    If iTerm = 12 And blRenewable Then
                        rgDB.Cells(i, 18).Value = 12    'Grant will expire in target year
                    ElseIf iTerm = 12 And Not blRenewable Then
                        rgDB.Cells(i, 18).Value = -12    'Grant does not have a renewable BLI code
                    ElseIf iTerm > 12 Then
                        rgDB.Cells(i, 18).Value = -121    'Grant will not expire in target year
                    End If
                Else
                    rgDB.Cells(i, 18).Value = -13    'Grant is two or more years old & not defined to LOCCS
                End If
            End If
        '-------------------------------------------------------------------------------------------
        'GRANT IS NOT DEFINED to LOCCS
        '-------------------------------------------------------------------------------------------
        ElseIf blNotinLOCCS = True Then
            If iPrjYear + 2 = iExpYear Then   'Most Recent Project Year
                If iTerm = 12 Then
                    rgDB.Cells(i, 18).Value = 30    'Grant will expire in target year
                ElseIf iTerm > 12 Then
                    rgDB.Cells(i, 18).Value = -30    'Grant will not expire in target year
                End If
            Else
                rgDB.Cells(i, 18).Value = -31    'Grant is two or more years old & not defined to LOCCS
            End If
        End If
Nexti:
    Next i
    Debug.Print "ExpGrantSHP", , Format(Timer - t, "#0.#00"); "  Filter all SHP renewal candidates"
End Sub
Sub ExpGrantSPC()
 
    Dim i As Long, j As Long, k As Long
    Dim iExpdtYear
    Dim dtExpDate As Date
    Dim dtEffDate As Date
    Dim rgMyRange As Range
    Dim rgDB As Range
    Dim MonthsElapsed As String
    Dim Flag As Integer
    Dim PctAwardSpent As Double
    Dim PctTermExp As Double
    Dim BLICodes As String
    Dim Balance As Currency
    Dim Award As Double
    Dim iPrjYear As Integer
    Dim iRptYear As Integer
    Dim iTerm As Integer
    Dim iCoCTerm As Integer
    Dim blNotinLOCCS As Boolean
    Dim blRenewable As Boolean
    Dim blPRAW As Boolean
    Dim t As Single
    t = Timer
    Call SetWkbObjects
 
    Application.ScreenUpdating = False
    Workbooks(wkb3.Name).Sheets("Sheet1").Activate
    Set rgMyRange = Range("$A1").CurrentRegion
    ActiveWorkbook.Names.Add Name:="Database", RefersToR1C1:=rgMyRange
    With Range("Database")
        If .Rows.Count = 1 Then
         Set rgDB = .Offset(1, 0).Resize(.Rows.Count)
        Else
         Set rgDB = .Offset(1, 0).Resize(.Rows.Count - 1)
        End If
    End With
    '------------------------------------
    'iExpYear = 2006    'FOR DEBUG ONLY
    '------------------------------------
    For i = 1 To rgDB.Rows.Count
'-------------------------------------------------------------------------------------
'Get the values of fields needed for this analysis
'-------------------------------------------------------------------------------------
        rgDB.Cells(i, 18).Value = 0                 'Reset "Activity" flag
        If IsNumeric(rgDB.Cells(i, 15).Value) Then  'Test "Term_months"
            iTerm = rgDB.Cells(i, 15).Value
        Else
            iTerm = 0
        End If
        If IsDate(rgDB.Cells(i, 13).Value) Then     'Test "Eff_Date"
            dtEffDate = rgDB.Cells(i, 13).Value
        Else
            dtEffDate = #1/1/200#
        End If
        If IsNumeric(rgDB.Cells(i, 7).Value) Then   'Test "Year"
            iPrjYear = rgDB.Cells(i, 7).Value
        Else
            iPrjYear = 0
        End If
        Balance = rgDB.Cells(i, 22).Value
        BLICodes = rgDB.Cells(i, 19).Value
        PctAwardSpent = rgDB.Cells(i, 25).Value
        MonthsElapsed = rgDB.Cells(i, 17).Value
        If InStr(1, rgDB.Cells(i, 12).Value, "Not in LOCCS") > 0 Then   'Test "Grantee_TID"
            blNotinLOCCS = True
        Else
            blNotinLOCCS = False
        End If
        If InStr(1, rgDB.Cells(i, 19).Value, "PRAW") > 0 Then   'Test "BLICODES"
            blPRAW = True
        Else
            blPRAW = False
        End If
        If IsNumeric(rgDB.Cells(i, 7).Value) Then
            iPrjYear = rgDB.Cells(i, 7).Value
        Else
            iPrjYear = 0
        End If
'---------------------------------------------------------------------------------------
'START THE SPC EXPIRED GRANT ANALYSIS
'---------------------------------------------------------------------------------------
        If blNotinLOCCS = True Then
        '------------------------------
        'GRANT IS NOT DEFINED to LOCCS
        '------------------------------
            If iPrjYear + 2 = iExpYear Then   'Most Recent Project Year
                If iTerm = 12 Then
                    rgDB.Cells(i, 18).Value = 1    'Grant will expire in target year
                ElseIf iTerm > 12 Then
                    rgDB.Cells(i, 18).Value = -1   'Grant will not expire in target year
                End If
            Else
                rgDB.Cells(i, 18).Value = -11       'If S+C not a renewal then term = 5/10 years
            End If
 
        ElseIf blNotinLOCCS = False Then
        '---------------------------------
        'GRANT IS DEFINED TO LOCCS
        '---------------------------------
            If Balance < 500 Then
                rgDB.Cells(i, 18).Value = -12   'Expired Grant
            ElseIf PctAwardSpent > 0.98 Then
                rgDB.Cells(i, 18).Value = -13   'Expired Grant
            ElseIf blPRAW = True Then
            '--------------------------------
            'Step #1: Analyze the 10 year grants first
            '--------------------------------
                dtExpDate = DateAdd("m", 120, dtEffDate)
                If Year(dtExpDate) = iExpYear Then
                   'debug.print Year(dtExpDate), iExpYear
                    rgDB.Cells(i, 18).Value = 23
                ElseIf MonthsElapsed < 120 Then
                    rgDB.Cells(i, 18).Value = -22
                ElseIf (PctAwardSpent < 0.75) Then
                    rgDB.Cells(i, 18).Value = -23
                ElseIf (PctAwardSpent > 0.85) Then
                    rgDB.Cells(i, 18).Value = 24
                End If
           ElseIf iPrjYear + 2 = iExpYear Then   'Most Recent Project Year
            '-----------------------------------------
            'Step #2: Analyze the recent 1 yr renewals
            '-----------------------------------------
                If rgDB.Cells(i, 6).Value = "SPCR" Then
                    rgDB.Cells(i, 18).Value = 2   'Recent Grant with 1 yr term
                Else
                    rgDB.Cells(i, 18).Value = -2   'Recent Grant with 5/10 yr term
                End If
            '-----------------------------------------
            'Step #3: Analyze the rest of the five year grants
            '-----------------------------------------
            ElseIf IsDate(dtEffDate) Then
                dtExpDate = DateAdd("m", 60, dtEffDate)
                If Year(dtExpDate) = iExpYear Then
                '-------------------------------------
                'This grant expires in the target year
                '-------------------------------------
                    rgDB.Cells(i, 18).Value = 21
                ElseIf MonthsElapsed < 60 Then
                '-------------------------------------
                'This grant will not expire in target year
                '-------------------------------------
                    rgDB.Cells(i, 18).Value = -20
                '-------------------------------------
                'these grants may have been extended
                '-------------------------------------
                ElseIf (PctAwardSpent < 0.89) Then
                '-------------------------------------
                'This grant has funds for one year
                '-------------------------------------
                    rgDB.Cells(i, 18).Value = 22
                Else
                    rgDB.Cells(i, 18).Value = -21
                End If
 
            End If
        End If
    Next i
    Debug.Print "ExpGrantSPC", , Format(Timer - t, "#0.#00")
End Sub
Sub Buttons()
    Dim rgRow1 As Range
    Dim wkb As Workbook
    Dim ValidDate As Boolean
    Dim Opin As Variant
    Dim t As Single
    sSTButton = Timer
    t = Timer
    Application.ScreenUpdating = False
    Call SetWkbObjects  'Also calculates iExpYear for Buttons 1 & 2
    If wkb2 Is Nothing Then
        PublicMsg = "NO A67R1 FILE AVAILABLE - ABORT"
        Exit Sub
    End If
    If Fn_IsWorkbookOpen(stWkb3Name) Then
        wkb1.Activate
        Worksheets("Macros").Activate
        PublicMsg = ("This filter has already been saved as" & Chr(13) & stWkb3Name & Chr(13) _
            & " SELECT ANOTHER OPTION")
        fmProgress.Hide
        Exit Sub
    'ElseIf iButtonNmbr = 1 And LOCCS_RowsCnt(7, Str(iRptYear - 1)) < 10 Then
    '-------------------------------------------------------------------------------
    'Button #1 - If this is a 2006 report year and there are NO 2005 PROJECTS then exit
    'with an error message
    '-------------------------------------------------------------------------------
    '    PublicMsg = "There are no projects in the A67 report for year " & Str(iRptYear - 1) _
    '    & Chr(13) & "Button will not run - Select another option"
    '    fmProgress.Hide
    '    Exit Sub
    Else                                'Prepare an empty workbook for this button filter
        Set wkb3 = Workbooks.Add
        Application.DisplayAlerts = False   'Create a new, empty workbook for this filter
            wkb3.SaveAs Filename:=stWkb3Name
        Application.DisplayAlerts = True
    End If
    '------------------------------------------------------------------------------------
    'Set up A67R1 file so that no autofilter is active and no column in range 1- 38 is hidden
    '------------------------------------------------------------------------------------
    Application.ScreenUpdating = False
    Workbooks(wkb2.Name).Worksheets("LOCCS_ALL").Activate
    With Worksheets("LOCCS_ALL").Activate
        Range(Cells(1, 1), Cells(1, 38)).EntireColumn.Hidden = False
        Range(Cells(1, 39), Cells(1, 128)).EntireColumn.Hidden = True
        If ActiveSheet.AutoFilterMode = True Then Range("$A$1").CurrentRegion.AutoFilter
    End With
    fmProgress.Show vbModeless
    fmProgress.pcProgress (2)
    Debug.Print "Buttons", , Format(Timer - t, "#0.#00"); "  Time to create a new, empty Workbook"
    Call FilterA67              'First pass filter on A67 and save to Workbook3
    Call Buttons_SetCol   'Set the default columns widths for all fields in wkb3
    Call Pass2Filter            'Create and Apply the second pass filter on data
    Call HighlightRows          'If applicable, highlight rows that are questionable
    Call DeleteRows             'Delete records  not meeting second pass filter criteria
    Call CopyTextBox            'Copy a textbox to end of new file
    Call FILTERSUBTOTALS        'Insert the Subtotals formulas to end of new file
    Call SetEmptyFields          'For B21 ':031106
    Call ColorCells1
    Call RenameFields
    Call FinalFilter            'Apply  final formatting to  new data file - specific to button
    Call FormatBorders
    Call FormatPage          'Format  new file - This routine is generic to Buttons
    Call PivotTables
    Call CopyTextBox_PT
    Call EndOfFilter            'Save the final filtered file and post a message
    'Debug.Print "Buttons", , Format(Timer - t, "#0.#00")
End Sub
Sub B19_NotinLOCCS()
 
    Dim i As Long, j As Long, k As Long
    Dim rgMyRange As Range
    Dim rgDB As Range
    Dim t As Single
    Dim blGrantCancel As Boolean
    Dim blNotinLOCCS As Boolean
 
    t = Timer
    Call SetWkbObjects
 
    Application.ScreenUpdating = False
    Workbooks(wkb3.Name).Sheets("Sheet1").Activate
    Set rgMyRange = Range("$A1").CurrentRegion
    ActiveWorkbook.Names.Add Name:="Database", RefersToR1C1:=rgMyRange
    With Range("Database")
        If .Rows.Count = 1 Then
         Set rgDB = .Offset(1, 0).Resize(.Rows.Count)
        Else
         Set rgDB = .Offset(1, 0).Resize(.Rows.Count - 1)
        End If
    End With
 
    For i = 1 To rgDB.Rows.Count
        rgDB.Cells(i, 18).Value = -1         'Set flag to "delete" by default
        blGrantCancel = False
        If InStr(1, rgDB.Cells(i, 35).Value, ":Can") > 0 Then: blGrantCancel = True
        If (InStr(1, rgDB.Cells(i, 12).Value, "Not in LOCCS") > 0) And (Not blGrantCancel) Then
                rgDB.Cells(i, 18).Value = 4 'Grant will be deobligated this september
        End If
    Next i
    Debug.Print "B19_NotinLOCCS", , Format(Timer - t, "#0.#00")
End Sub
Sub FinalFilter()
 
 
    Dim i As Long
    Dim strow As String
    Dim lrow As Long
    Dim stCriteria As String
    Dim rgWkb3 As Range
    Dim t As Single
 
    t = Timer
    Application.ScreenUpdating = False
 
    Set rgWkb3 = Workbooks(wkb3.Name).Worksheets("Sheet1").Range("A1").CurrentRegion
    With ActiveSheet
        .UsedRange      'Reset the last cell
        Select Case iButtonNmbr
        '------------------------------------------------------------------------------
        Case 1 To 2          '(1)Expiring Grants SHP  (2) SPC
        '---------------------------------------------------------------
        'Format Report for final output. Hide fields, Rename Field Names
        '---------------------------------------------------------------
            .Range(Cells(1, 3), Cells(1, 47)).EntireColumn.Hidden = True
            .Range(Cells(1, 48), Cells(1, 54)).ColumnWidth = 11
            Range(Cells(1, 48), Cells(1, 54)).EntireColumn.NumberFormat = "$#,##0"
            .Cells(1, 9).EntireColumn.Hidden = False        'Applicant Name
            .Cells(1, 11).EntireColumn.Hidden = False       'Project Name
            .Cells(1, 11).EntireColumn.HorizontalAlignment = xlLeft   'Project Name
            .Cells(1, 14).EntireColumn.Hidden = False       'Start Date
            .Cells(1, 14).EntireColumn.HorizontalAlignment = xlLeft   'Start Date
            .Cells(1, 15).EntireColumn.Hidden = False       'Term in months
            .Cells(1, 16).EntireColumn.Hidden = False       'Expiration Date
            .Cells(1, 16).EntireColumn.HorizontalAlignment = xlLeft   'Expiration Date
            '.Cells(1, 18).EntireColumn.Hidden = False       'Activity
            '.Cells(1, 19).EntireColumn.Hidden = False       'BLI_codes
            '.Cells(1, 20).EntireColumn.Hidden = False       'LOCCS Authorized Amount
            .Cells(1, 29).EntireColumn.Hidden = False       'CoC_Name
            '.Cells(1, 31).EntireColumn.Hidden = False       'CoC Term in Years
            '.Cells(1, 33).EntireColumn.Hidden = False       'CoC Authorized Amount
            '.Cells(1, 34).EntireColumn.Hidden = False       'CoC Continuum Name
            Range(Cells(1, 1), Cells(1, 54)).HorizontalAlignment = xlCenter
            ActiveWindow.FreezePanes = False
            ActiveWindow.SplitRow = 1
            ActiveWindow.SplitColumn = 4
            ActiveWindow.FreezePanes = True
            Selection.AutoFilter
            '-----------Sort report by Grantee then LOCCS_Nmbr-----------
            'Range("A1").Select
            'Selection.Sort Key1:=Range("I2"), Order1:=xlAscending, Key2:=Range("A2") _
            '    , Order2:=xlAscending, Key3:=Range("A2"), Order3:=xlAscending, Header:= _
            '    xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        '---------------------------------------------------------------------------------
        Case 4         ' ExpBal SHP/SPC/YB/HPAC
            .Cells(1, 2).EntireColumn.Hidden = True     'PIN
            .Cells(1, 6).EntireColumn.Hidden = True     'CoCPgmCode
            .Cells(1, 12).EntireColumn.Hidden = True    'Grantee_TID
            .Cells(1, 18).EntireColumn.Hidden = True    'Activity
            .Cells(1, 19).EntireColumn.Hidden = True    'BLI_codes
            .Range(Cells(1, 23), Cells(1, 37)).EntireColumn.Hidden = True
            ActiveWindow.FreezePanes = False
            ActiveWindow.SplitRow = 1
            ActiveWindow.SplitColumn = 4
            ActiveWindow.FreezePanes = True
            Selection.AutoFilter
            '-----------Sort report by Rep then Program then Tax ID-----------
            Range("A1").Select
            Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("E2") _
                , Order2:=xlAscending, Key3:=Range("L2"), Order3:=xlAscending, Header:= _
                xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        '---------------------------------------------------------------------------------
        Case 8         ' SlowSpender SHP/SPC/YB/HPAC
            .Cells(1, 6).EntireColumn.Hidden = True
            .Cells(1, 12).EntireColumn.Hidden = True    'Grantee_TID
            .Cells(1, 18).EntireColumn.Hidden = True    'Activity
            .Cells(1, 19).EntireColumn.Hidden = True    'BLI_codes
            .Range(Cells(1, 23), Cells(1, 37)).EntireColumn.Hidden = True
            ActiveWindow.FreezePanes = False
            ActiveWindow.SplitRow = 1
            ActiveWindow.SplitColumn = 4
            ActiveWindow.FreezePanes = True
            Selection.AutoFilter
        '------------------------------------------------------------------------------
        Case 12          'SHP Restrictive Covenants - All Years
            .Cells(1, 2).EntireColumn.Hidden = True     'PIN
            .Cells(1, 12).EntireColumn.Hidden = True    'Grantee_TID
            .Cells(1, 18).EntireColumn.Hidden = True    'Activity
            .Range(Cells(1, 13), Cells(1, 16)).EntireColumn.Hidden = True
            .Range(Cells(1, 23), Cells(1, 37)).EntireColumn.Hidden = True
            ActiveWindow.FreezePanes = False
            ActiveWindow.SplitRow = 1
            ActiveWindow.SplitColumn = 4
            ActiveWindow.FreezePanes = True
            Selection.AutoFilter
            '-----------Sort report by Grantee then LOCCS_Nmbr-----------
            Range("A1").Select
            Selection.Sort Key1:=Range("I2"), Order1:=xlAscending, Key2:=Range("A2") _
                , Order2:=xlAscending, Key3:=Range("A2"), Order3:=xlAscending, Header:= _
                xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        '------------------------------------------------------------------------------
        Case 17     'Active Grants SHP/SPC/YB/HPAC
            '-------------Hide Columns----------------------------------
            .Cells(1, 2).EntireColumn.Hidden = True
            .Cells(1, 17).EntireColumn.Hidden = True
            .Range(Cells(1, 12), Cells(1, 12)).EntireColumn.Hidden = True
            .Range(Cells(1, 23), Cells(1, 34)).EntireColumn.Hidden = True
            '--------Split Screen, Freeze Panes and turn Autofilters ON--------------
            ActiveWindow.FreezePanes = False
            ActiveWindow.SplitRow = 1
            ActiveWindow.SplitColumn = 4
            ActiveWindow.FreezePanes = True
            Selection.AutoFilter
                    '-------------------------------------------------------------------
        Case 18     'Workloads Button 18
                    'Button 18 renames and moves fields. Don't use A67 field locations
                    'to locate or format data
                    '--------------------------------------------------------------------
            .Range(Cells(1, 1), Cells(1, 38)).EntireColumn.Hidden = False
            '-----------------Move Columns --------------------------------------
            .Cells(1, 26).EntireColumn.Cut                      'Slowspender
            .Cells(1, 4).Insert shift:=xlToRight
            .Cells(1, 31).EntireColumn.Cut                      'October Recapture
            .Cells(1, 5).Insert shift:=xlToRight
            .Cells(1, 32).EntireColumn.Cut                      'Needs Site Control
            .Cells(1, 6).Insert shift:=xlToRight
            .Range(Cells(1, 29), Cells(1, 30)).EntireColumn.Cut 'Needs Covenant, Needs Env
            .Cells(1, 7).Insert shift:=xlToRight
            .Range(Cells(1, 4), Cells(1, 8)).ColumnWidth = 10
            .Range(Cells(1, 4), Cells(1, 8)).HorizontalAlignment = xlCenter
            '----------------- Hide Columns --------------------------------------
            .Cells(1, 2).EntireColumn.Hidden = True     'PIN
            .Cells(1, 9).EntireColumn.Hidden = True     'LOCCS_Nmbr1
            .Cells(1, 11).EntireColumn.Hidden = True    'CoCPgmCode
            .Cells(1, 17).EntireColumn.Hidden = True    'Grantee_TID
            .Range(Cells(1, 21), Cells(1, 23)).EntireColumn.Hidden = True
            .Range(Cells(1, 28), Cells(1, 34)).EntireColumn.Hidden = True
            .Range(Cells(1, 36), Cells(1, 38)).EntireColumn.Hidden = True
             .Cells(1, 23).EntireColumn.Hidden = False    'Activity Flag Codes
           '----------------- Set up the Page --------------------------------------
            ActiveWindow.FreezePanes = False
            ActiveWindow.SplitRow = 1
            ActiveWindow.SplitColumn = 9
            ActiveWindow.FreezePanes = True
            Selection.AutoFilter
            '-----------Sort the database by Rep then Grant# -----------
            Range("A1").Select
            Selection.Sort Key1:=Range("C2"), Order1:=xlAscending, Key2:=Range("D2") _
                , Order2:=xlAscending, Key3:=Range("L2"), Order3:=xlAscending, Header:= _
                xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
            Call B18_CopyFormulas
        '---------------------------------------------------------------------------------
        Case 19 To 21:  ' Rpt3
            .Cells(1, 12).EntireColumn.Hidden = True    'Grantee_TID
            .Cells(1, 18).EntireColumn.Hidden = True    'Activity
            .Cells(1, 19).EntireColumn.Hidden = True    'BLI_codes
            .Range(Cells(1, 23), Cells(1, 37)).EntireColumn.Hidden = True
            .Cells(1, 35).EntireColumn.Hidden = False    'Status
            .Cells(1, 36).EntireColumn.Hidden = False    'User1
            .Range(Cells(1, 38), Cells(1, 128)).EntireColumn.Hidden = True
            ActiveWindow.FreezePanes = False
            ActiveWindow.SplitRow = 1
            ActiveWindow.SplitColumn = 4
            ActiveWindow.FreezePanes = True
            Selection.AutoFilter
        Case 22:        ' NoSiteControl
            .Cells(1, 6).EntireColumn.Hidden = True
            .Cells(1, 18).EntireColumn.Hidden = True    'Activity
            '.Cells(1, 19).EntireColumn.Hidden = True    'BLI_codes
            .Range(Cells(1, 13), Cells(1, 18)).EntireColumn.Hidden = True
            .Range(Cells(1, 23), Cells(1, 37)).EntireColumn.Hidden = True
            .Cells(1, 30).EntireColumn.Hidden = False    'CoCComponent(PH/TH/SS,etc)
            ActiveWindow.FreezePanes = False
            ActiveWindow.SplitRow = 1
            ActiveWindow.SplitColumn = 4
            ActiveWindow.FreezePanes = True
            Selection.AutoFilter
        Case 23:        ' Covenants
            .Cells(1, 6).EntireColumn.Hidden = True
            .Cells(1, 18).EntireColumn.Hidden = True    'Activity
            '.Cells(1, 19).EntireColumn.Hidden = True    'BLI_codes
            .Range(Cells(1, 13), Cells(1, 18)).EntireColumn.Hidden = True
            .Range(Cells(1, 23), Cells(1, 37)).EntireColumn.Hidden = True
            .Cells(1, 30).EntireColumn.Hidden = False    'CoCComponent(PH/TH/SS,etc)
            ActiveWindow.FreezePanes = False
            ActiveWindow.SplitRow = 1
            ActiveWindow.SplitColumn = 4
            ActiveWindow.FreezePanes = True
            Selection.AutoFilter
    End Select
    .UsedRange      'Reset the last cell
End With
    fmProgress.pcProgress (95)
    Debug.Print "FinalFilter", , Format(Timer - t, "#0.#00"); "  Hide unused Columns & Sort"
End Sub
Sub SetButtonsArray()
 
    'Debug.Print "SetButtonsArray()", "       Set buttons names"
    vButtonsArray(0, 1) = "Grants Eligible for Renewal.SHP" 'ACTIVE BUTTON
    vButtonsArray(0, 2) = "Grants Eligible for Renewal.SPC" 'ACTIVE BUTTON
    vButtonsArray(0, 3) = "Expired Balance.SPC"
    vButtonsArray(0, 4) = "Grantees with Expired grants with +Balances.ALL"             'ACTIVE BUTTON
    vButtonsArray(0, 5) = "Expired Balance.YB"
    vButtonsArray(0, 6) = "Expired Balance.HPAC"
    vButtonsArray(0, 7) = ""
    vButtonsArray(0, 8) = "Problem Spenders.ALL"            'Problem Spenders All 012106
    vButtonsArray(0, 9) = "Problem Spenders.SPC"
    vButtonsArray(0, 10) = "Problem Spenders.YB"
    vButtonsArray(0, 11) = "Problem Spenders.HPAC"
    vButtonsArray(0, 12) = "Restrictive Covenants.SHP"
    vButtonsArray(0, 13) = "Active Grants.SHP"
    vButtonsArray(0, 14) = "Active Grants.SPC"
    vButtonsArray(0, 15) = "Active Grants.YB"
    vButtonsArray(0, 16) = "Active Grants.HPAC"
    vButtonsArray(0, 17) = "Office Workload by Rep"
    vButtonsArray(0, 18) = "Problem Grants"
    vButtonsArray(0, 19) = "Grants Not Defined to LOCCS"
    vButtonsArray(0, 20) = "Grantee Count"
    vButtonsArray(0, 21) = "Grants-Potential Loss of Funding This Sept"
    vButtonsArray(0, 22) = "SHP Grants Needing Site Control"
    vButtonsArray(0, 23) = "SHP grants Needing Restrictive Covenants"
   '----------NO LONGER USED - References to text boxes----------------
    vButtonsArray(1, 1) = 2
    vButtonsArray(1, 2) = 33
    vButtonsArray(1, 3) = 38
    vButtonsArray(1, 4) = 39
    vButtonsArray(1, 5) = 40
    vButtonsArray(1, 6) = 40
    vButtonsArray(1, 7) = 0
    vButtonsArray(1, 8) = 32
    vButtonsArray(1, 9) = 41
    vButtonsArray(1, 10) = 35
    vButtonsArray(1, 11) = 35
    vButtonsArray(1, 12) = 34
    vButtonsArray(1, 13) = 36
    vButtonsArray(1, 14) = 36
    vButtonsArray(1, 15) = 36
    vButtonsArray(1, 16) = 36
    vButtonsArray(1, 17) = 36
    vButtonsArray(1, 18) = 0
    vButtonsArray(1, 19) = 0
    vButtonsArray(1, 20) = 0
    vButtonsArray(1, 21) = 0
    vButtonsArray(1, 22) = 0
    vButtonsArray(1, 23) = 0
End Sub
Sub ColorCells1()
 
    Dim vColorThis1 As Variant
    Dim vColorThis2 As Variant
    Dim iCol1 As Integer
    Dim iCol2 As Integer
    Dim Rng As Range
    Dim stData As String
    Dim t As Double
    Dim i As Long
 
    t = Timer
    Application.ScreenUpdating = False
 
    Select Case iButtonNmbr
        Case 1  'SHP Annual Renewal Test
            vColorThis1 = "Not in LOCCS": iCol1 = 14
            vColorThis2 = "2006-Estimated": iCol2 = 16
        Case 19
            vColorThis1 = 4:  iCol1 = 12
        Case Else
            Exit Sub
    End Select
    Application.ScreenUpdating = False
    Range("A1").CurrentRegion.Name = "A67data"
    Set Rng = Range("A67data")
    For i = 1 To Rng.Rows.Count
        'Debug.Print rngDates(i, 9).Value
        If Rng(i, iCol1).Value = vColorThis1 Then
            Rng(i, iCol1).Font.ColorIndex = 3
        End If
        If iCol2 = 0 Then
            Exit Sub
        ElseIf Trim(Rng(i, iCol2).Value) = vColorThis2 Then
            Rng(i, iCol2).Font.ColorIndex = 3
        End If
    Next i
    fmProgress.pcProgress (90)
    Debug.Print "ColorCells1", , Format((Timer - t), "#0.#00"); "  Color text if needed"
End Sub
Sub A67OfficeUpdate()
 
 
 
    'Public stCPDOffices(1, iFOCnt)
    'Public stNationalName As String
    'Public stCoCPath As String
    'Public stCPDOffice As String       'Set by SetCPDOffice()
 
    Dim stCriteria As String
    Dim lLastRow As Long
    Dim stColumn As String, strow As String
    Dim Rng As Range
    Dim wkb As Workbook
    Dim wkb1 As Workbook
    Dim wkb2 As Workbook
    Dim t As Single
    Debug.Print "    Call A67OfficeUpdate()"
    t = Timer
    Set wkb1 = ThisWorkbook
    For Each wkb In Workbooks
        If InStr(1, wkb.Name, "A67R1.") > 0 Then Set wkb2 = wkb
        If InStr(1, wkb.Name, "BOSSNAP") > 0 Then Set wkb1 = wkb
    Next wkb
 
 
    'stCPDOffice = "Houston" '------------DEBUG ONLY --------------
 
    Select Case stCPDOffice
        Case "San Francisco"
            'stColumn = "A1"
            'stCriteria = "F25:F31" 'Delete Los Angeles records
        Case "Houston"
            Call A67SetCoCID("Houston")
            Call A67SetCriteria("Houston")
            stColumn = "AC1"
            stCriteria = "AI1:AI26" 'Delete Houston records
        Case "Seattle"
            Call A67SetCriteria("Seattle")
            stColumn = "H1"
            stCriteria = "AI1:AI4" 'Delete Seattle records
        Case Else
            Debug.Print "A67OfficeUpdate", , "CPD Office " & stCPDOffice & " does not need filtering"
            stCriteria = ""
 
    End Select
 
    If stCriteria = "" Then Exit Sub
 
    Application.ScreenUpdating = False
    wkb2.Activate
    strow = Mid(stColumn, 1, 1)
    Rows(1).Insert
    Range(stColumn).Value = "Temp"
    wkb2.Worksheets("LOCCS_ALL").Activate
    With ActiveSheet
        .UsedRange
        lLastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
        Set Rng = Range(stColumn, Cells(lLastRow, strow))
        Rng.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
        wkb1.Sheets("Criteria").Range(stCriteria), Unique _
        :=False
'        rng.AutoFilter Field:=1, Criteria1:=stCriteria
        Rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .UsedRange
        ActiveSheet.ShowAllData
    End With
    'Application.ScreenUpdating = True
    'Range("A1").Select
    'Application.ScreenUpdating = False
    Debug.Print "    A67OfficeUpdate", Format((Timer - t), "#0.#00"), "CPD Office A67 Filters"
End Sub
Sub SlowSpenderYB_HOPWA()
 
    Dim rgMyRange As Range
    Dim rgDB As Range
 
    Dim stStartDate As String
    Dim Term As Long
    Dim MonthsElapsed As String
    Dim Flag As Integer
    Dim PctAwardSpent As Double
    Dim PctTermExp As Double
    Dim Balance As Currency
    Dim Award As Double
    Dim iYear As Integer
    Dim iRptYear As Integer
    Dim vStartDate As Variant
    Dim i As Integer
 
    Call SetWkbObjects
 
    If wkb3 Is Nothing Then MsgBox ("Error in Subroutine ButtonFilters - ABORT")
    Application.ScreenUpdating = False
    Workbooks(wkb3.Name).Sheets("Sheet1").Activate
    Set rgMyRange = Range("$A1").CurrentRegion
    ActiveWorkbook.Names.Add Name:="Database", RefersToR1C1:=rgMyRange
    With Range("Database")
        If .Rows.Count = 1 Then
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count)
        Else
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count - 1)
        End If
    End With
 
 
    For i = 1 To rgDB.Rows.Count
        rgDB.Cells(i, 13).Value = 0
        stStartDate = rgDB.Cells(i, 9).Value
        PctAwardSpent = rgDB.Cells(i, 20).Value
        PctTermExp = rgDB.Cells(i, 19).Value
        MonthsElapsed = rgDB.Cells(i, 12).Value
  '-------------------------------------------
  ' Only analyze grants that have not expired with balances greater than 0
  '-------------------------------------------
        If (PctTermExp > 0.99) Then
            rgDB.Cells(i, 13).Value = -1
        ElseIf (PctAwardSpent > 0.995) Then
            rgDB.Cells(i, 13).Value = -2
 
  '-------------------------------------------------
  ' Grant is defined to LOCCS and has not expired - Test for a 25% difference
  '-------------------------------------------------
        ElseIf (PctTermExp < 1) And (PctTermExp - PctAwardSpent < 0.25) Then
            rgDB.Cells(i, 13).Value = -5
        ElseIf (PctTermExp < 1) And (PctTermExp - PctAwardSpent > 0.25) Then
            rgDB.Cells(i, 13).Value = 5
        End If
    Next i
End Sub
Sub CopyTextBoxTop()
'
'
    Call SetWkbObjects
'
'   Public stTextBoxNm AS String
'   Public stbutton As String
'
    Dim i As Long
    Dim iBoxSize As Integer
    Dim stTextboxRow As String
 
    fmProgress.pcProgress (50)
 
    iBoxSize = 50
    Select Case iButtonNmbr
        Case 1:     stTextBoxNm = "Text Box 50": iBoxSize = 60  'Grants Eligible for Renewal.SHP
        Case 2:     stTextBoxNm = "Text Box 51"                 'Grants Eligible for Renewal.SPC
        Case 3:     stTextBoxNm = ""
        Case 4:     stTextBoxNm = ""
        Case 5:     stTextBoxNm = ""
        Case 6:     stTextBoxNm = ""
        Case 8:     stTextBoxNm = "Text Box 52": iBoxSize = 80  'Problem Spenders.SHP
        Case 9:     stTextBoxNm = "Text Box 53"                 'Problem Spenders.SPC
        Case 10:    stTextBoxNm = "Text Box 54"                 'Problem Spenders.YB
        Case 11:    stTextBoxNm = "Text Box 54"                 'Problem Spenders.HPAC
        Case 12:    stTextBoxNm = ""
        Case 13:    stTextBoxNm = ""
        Case 14:    stTextBoxNm = ""
        Case 15:    stTextBoxNm = ""
        Case 16:    stTextBoxNm = ""
        Case 17:    stTextBoxNm = ""
        Case 18:    stTextBoxNm = "Text Box 49"     'RPT1-Workload Assignments by CPD Rep
        Case 19:    stTextBoxNm = "Text Box 46"     'Grants Not Defined to LOCCS
        Case 20:    stTextBoxNm = "Text Box 48"     'Grantee Count
        Case 21:    stTextBoxNm = "Text Box 47"     'Grants-Potential Loss of Funding This Sept
        Case Else
            stTextBoxNm = ""
    End Select
    If stTextBoxNm = "" Then Exit Sub
    Application.ScreenUpdating = False
    Rows("1:2").Select
    Selection.Insert shift:=xlDown
    Rows("1:1").Select
    Selection.RowHeight = iBoxSize
    wkb1.Activate
    Worksheets("Criteria").Activate
    ActiveSheet.Shapes(stTextBoxNm).Select
    Selection.Copy
    Worksheets("MACROS").Activate
    Application.ScreenUpdating = False
    wkb3.Activate
    Range("A1").Select
    ActiveSheet.Paste
    Selection.ShapeRange.IncrementLeft -45
    Selection.ShapeRange.IncrementTop -2
'    Rows(1).Select
End Sub
Sub A67Save()
    Dim wkb As Workbook
    Dim t As Single
    t = Timer
 
    If wkb2 Is Nothing Then
        For Each wkb In Workbooks
            If InStr(1, wkb.Name, "A67R1.") > 0 Then
                Set wkb2 = wkb                              'Set Public Variable Wkb2
                stMacroNm = wkb2.Name
                stMacroDir = ThisWorkbook.Path
                stA67Nm = wkb2.Name
            End If
        Next wkb
    End If
    wkb2.Activate
    If Fn_iDuplicate > 0 Then MsgBox ("Internal BOSSNAPS Error - send A67 file to Boston for analysis")
    Application.DisplayAlerts = False
    wkb2.Save
    Application.DisplayAlerts = True
    Range("A1").CurrentRegion.Select
    Selection.AutoFilter Field:=1
    Range("A1").Select
    Debug.Print "    A67Save", , Format((Timer - t), "#0.#00"), "Check for Duplicates & Save A67 file"
End Sub
Sub CoCUpdate()
    'Called only from Sub Depconprocess. Enter with PV stCoCPath set to CoC Report Name
    'Exit with Workbook Object Wkb4 set to CoC Report name
    'Using Ranges on Inactive Worksheets - page 102
    Dim rgDB As Range, rgMyRange As Range
    Dim i As Long, j As Long, k As Long
    Dim Rng As Range
    Dim rgFoundCell As Range
    Dim t As Single
    Dim stFindZZZ As String
    Dim stFoundCell As String
    Dim iCoCOfficeYear As Integer
    Dim stNewName As String
    Dim stCoCName As String
 
    t = Timer
    If blAbort Then Exit Sub
    If stDEPCONDir = "" Then Exit Sub
    If Not blCoCReports Then
        Debug.Print "    CoCUpdate", , "NO CoC Overview Reports to process - EXIT"
        Exit Sub
    End If
    If iCoCYear > 0 Then
        Debug.Print "    CoCUpdate", , , "Original Overview Report already updated - EXIT"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Set Wkb4 = Workbooks.Open(Filename:=stCoCPath)
    Workbooks(Wkb4.Name).Worksheets("Sheet1").Activate
    '-------------------------------------------------------------------------
    ':012806 You are here because THIS IS THE ORIGINAL COC REPORT that has user
    'entered updates for only the "Rep" field.
    'Fix the BLICODES (field 18, ("S") column) problem with junk data by setting all
    'BLICODES to blanks.
    '-------------------------------------------------------------------------
    Set rgDB = Range("$A1", Range("S1").End(xlDown))
    For i = 2 To rgDB.Rows.Count
        stCoCName = Mid(rgDB.Cells(i, 16).Value, 1, 4)
        rgDB.Cells(i, 3).Value = stCoCName
        rgDB.Cells(i, 19).Value = ""    'Set "BLICODES" field to blanks
    Next i
    '-----------------------------------------------------------------------------
    'Test HQ CoC Overview file to see if it has been updated with 5 new fields and
    'all grant numbers in A67 report
    '-----------------------------------------------------------------------------
    Set Rng = Range("A1:W1")    '112505Update for new CoC file
    With ActiveSheet
        Cells(1, 19).Value = "BLICodes"
        Cells(1, 20).Value = "Status"
        Cells(1, 21).Value = "User1"
        Cells(1, 22).Value = "User2"
        Cells(1, 23).Value = "User3"
        .UsedRange      'Reset the last cell
    End With
    Workbooks(Wkb4.Name).Save
    '------------Copy the A67 Project #'s to Clipboard--------------------
    'Set Wkb2 = Workbooks.Open(Filename:=stA67FullNm)
    Workbooks(wkb2.Name).Worksheets("LOCCS_ALL").Activate
    With ActiveSheet
        .Range("$A2", Range("A2").End(xlDown)).Select
        Selection.Copy
    End With
    Workbooks(Wkb4.Name).Worksheets("Sheet1").Activate
    '-----------Paste the Clipboard to end of CoC report------------------
    With ActiveSheet
        Range("D1").End(xlDown).Offset(1, 0).Select 'Find the first empty cell
        '.UsedRange  'Reset the last cell
        .Paste
        .UsedRange  'Reset the last cell
        Range("$A1").CurrentRegion.Select
        '----------------Sort so that duplicates are grouped---------------------
        Selection.Sort Key1:=(Cells(1, 4)), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    End With
    '--------Mark the duplicates as "ZZZ" in the Project# Field--------------
    With ActiveSheet
        Set rgDB = Range("D1", Range("D2").End(xlDown))
        For i = 1 To rgDB.Rows.Count
            For j = 1 To 20         'Delete up to 20 duplicates
                If rgDB.Cells(i, 1).Value = rgDB.Cells(i + j, 1).Value Then
                    rgDB.Cells(i + j, 1).Value = "ZZZ"
                'Debug.Print i, j, rgDB.Cells(i, 1), rgDB.Cells(i, j + 1)
                Else
                    Exit For
                End If
            Next j
        Next i
        '-----------Sort the database so the "ZZZ" records are grouped at end -----------
        Range("$A1").CurrentRegion.Select
        Selection.Sort Key1:=(Cells(1, 4)), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        Set Rng = Range("D1", Range("D1").End(xlDown))
        stFindZZZ = Rng.Address
        '------------Find the first "ZZZ" record ---------------------------------
        Set rgFoundCell = Range(stFindZZZ).Find(what:="ZZZ")
        stFoundCell = rgFoundCell.Address
        '-------------------------------------------------------------------------------
        'Define a single range object that has all "ZZZ" records then delete the records
        '-------------------------------------------------------------------------------
        Range(stFoundCell, Range("D1").End(xlDown)).EntireRow.Delete
        .UsedRange
    End With
    Application.DisplayAlerts = False
    'Wkb2.Close     '-----------Leave A67 Report open to avoid reopening
    Workbooks(Wkb4.Name).Close SaveChanges:=True
    stNewName = stDEPCONDir + "\CoC_" + stCPDOffice + ".2004.xls"
    Name stCoCPath As stNewName
    stCoCPath = stNewName
    iCoCYear = 2004
    'stCoCName = "CoC_" + stCPDOffice + ".2004.xls" '------------Update the Overview file name reference
    Debug.Print "    CoCUpdate", , Format((Timer - t), "#0.#00"), stCoCPath
    End Sub
 
Sub A67_SetColumns()
 
    Dim rgRow1 As Range
    Dim i As Long
    Dim t As Single
    Dim A67AF As AutoFilter
 
 
    t = Timer
    'ActiveSheet.ShowAllData
    Application.ScreenUpdating = False
    'Workbooks(wkbObject.Name).Worksheets(stSheetName).Activate
    If ActiveSheet.AutoFilterMode = True Then   'Reset AUTOFILTER if active
        Range("$A$1").CurrentRegion.AutoFilter
    End If
    Set rgRow1 = Range("A1:DX1")
    With rgRow1
        .WrapText = True
        .Font.Bold = True
        .RowHeight = 40
        .VerticalAlignment = xlTop
        .HorizontalAlignment = xlCenter
        .Font.Bold = True
        .Interior.ColorIndex = 19
        .Interior.Pattern = xlSolid
        .Interior.PatternColorIndex = xlAutomatic
        Range(Cells(1, 1), Cells(1, 38)).EntireColumn.Hidden = False        'Unhide all non_BLI fields
        Range(Cells(1, 1), Cells(1, 38)).EntireColumn.HorizontalAlignment = xlCenter
        .Cells(1, 1).EntireColumn.ColumnWidth = 17                          'LOCCS_Nmbr
        .Cells(1, 2).EntireColumn.ColumnWidth = 14                          'LOCCS_Nmbr1
        Range(Cells(1, 3), Cells(1, 4)).EntireColumn.ColumnWidth = 6        'YEAR,State,
        Range(Cells(1, 5), Cells(1, 5)).EntireColumn.ColumnWidth = 8        'Program
        .Cells(1, 7).EntireColumn.ColumnWidth = 12                          'Grantee_TID
        Range(Cells(1, 8), Cells(1, 9)).EntireColumn.ColumnWidth = 10       'EFF_DATE, Start_Date
        Range(Cells(1, 8), Cells(1, 9)).EntireColumn.NumberFormat = "mm/dd/yy"
        .Cells(1, 9).EntireColumn.ColumnWidth = 6                          'Term_months
        .Cells(1, 10).EntireColumn.ColumnWidth = 8
        .Cells(1, 11).EntireColumn.ColumnWidth = 10                         'Exp_Date
        .Cells(1, 11).EntireColumn.NumberFormat = "mm/dd/yy"
        .Cells(1, 12).EntireColumn.ColumnWidth = 7                          'MonthsElapsed
        .Cells(1, 13).EntireColumn.ColumnWidth = 10                          'Activity
        Range(Cells(1, 3), Cells(1, 13)).EntireColumn.HorizontalAlignment = xlCenter
        .Cells(1, 6).EntireColumn.HorizontalAlignment = xlLeft
        .Cells(1, 7).EntireColumn.HorizontalAlignment = xlLeft
        Range(Cells(1, 14), Cells(1, 16)).EntireColumn.ColumnWidth = 14  'Authorized,Disbursed,Balance
        Range(Cells(1, 14), Cells(1, 16)).EntireColumn.NumberFormat = "$#,##0.00" 'Authorized,Disbursed,Balance
        Range(Cells(1, 14), Cells(1, 16)).EntireColumn.HorizontalAlignment = xlRight  'Authorized,Disbursed,Balance
        .Cells(1, 17).EntireColumn.ColumnWidth = 10    'LOCC_RptDate
        .Cells(1, 17).EntireColumn.NumberFormat = "mm/dd/yy"                'LOCC_RptDate
        .Cells(1, 18).EntireColumn.ColumnWidth = 15                         'BLI_Codes
        .Cells(1, 18).EntireColumn.HorizontalAlignment = xlLeft
        Range(Cells(1, 19), Cells(1, 23)).EntireColumn.ColumnWidth = 8 '%TermExpired,%AwardSpent,SlowSpender,ActiveGrant
        Range(Cells(1, 19), Cells(1, 20)).EntireColumn.NumberFormat = "0.00" '%TermExpired,%AwardSpent
        .Cells(1, 24).EntireColumn.ColumnWidth = 10                         'COC_Name
        .Cells(1, 25).EntireColumn.ColumnWidth = 8                          'PIN
        .Cells(1, 26).EntireColumn.ColumnWidth = 8                          'CoCPgmCode
        .Cells(1, 27).EntireColumn.ColumnWidth = 10                          'CoCComponet
        .Cells(1, 28).EntireColumn.ColumnWidth = 8                          'CoCTerm
        'Range(Cells(1, 17), Cells(1, 28)).EntireColumn.HorizontalAlignment = xlCenter
        Range(Cells(1, 29), Cells(1, 35)).EntireColumn.ColumnWidth = 16  'COCApplicant,CoCSponsor,CoCProjectName,CoCAward,CoCContName,Status
        Range(Cells(1, 29), Cells(1, 38)).EntireColumn.HorizontalAlignment = xlLeft  'COCApplicant _
        ',CoCSponsor,CoCProjectName,CoCAward,CoCContName,Status,Rep,User1,User2,User3
        '.HorizontalAlignment = xlLeft
        .Cells(1, 32).EntireColumn.NumberFormat = "$#,##0"                  'CoCAward
        .Cells(1, 32).EntireColumn.HorizontalAlignment = xlRight            'CoCAward
        .Cells(1, 33).EntireColumn.ColumnWidth = 6                          'CoCContName
        .Cells(1, 35).EntireColumn.ColumnWidth = 12                          'Rep
        Range(Cells(1, 36), Cells(1, 38)).EntireColumn.ColumnWidth = 8      'User1,User2,User3
        Range(Cells(1, 39), Cells(1, 128)).EntireColumn.ColumnWidth = 10    'BLI Data fields
        Range(Cells(1, 39), Cells(1, 128)).EntireColumn.NumberFormat = "$#,##0.00" 'BLI Data fields
        Range(Cells(1, 39), Cells(1, 128)).EntireColumn.Hidden = True       'BLI Data fields
        Range(Cells(1, 1), Cells(1, 128)).Borders(xlInsideVertical).Weight = xlThin
        Range(Cells(1, 1), Cells(1, 128)).HorizontalAlignment = xlCenter
        '------------------Move Columns ----------------------
        .Cells(1, 5).EntireColumn.Cut          'CoCComponentCode (SHP/SHPR)
        .Cells(1, 3).Insert shift:=xlToLeft
        .Cells(1, 18).EntireColumn.Cut          'BLI Codes
        .Cells(1, 14).Insert shift:=xlToLeft
        .Cells(1, 25).EntireColumn.Cut          'BLI Codes
        .Cells(1, 2).Insert shift:=xlToLeft
        .Cells(1, 26).EntireColumn.Cut          'BLI Codes
        .Cells(1, 5).Insert shift:=xlToLeft
        .Cells(1, 30).EntireColumn.Cut          'Project Sponsor
        .Cells(1, 9).Insert shift:=xlToRight
        .Cells(1, 31).EntireColumn.Cut          'Project Name
        .Cells(1, 10).Insert shift:=xlToRight
        .Cells(1, 35).EntireColumn.Cut          'Rep
        .Cells(1, 3).Insert shift:=xlToLeft
    End With
    Debug.Print "    A67_SetColumns", Format(Timer - t, "#0.#00"), "Final format & arrange of A67 data"
End Sub
Sub CoCStatus()
    'Public blCoCUpdated As Boolean      'CoC Update flag from Sub CoCStatus()
    'Public blA67Updated As Boolean      'A67 Update flag from Sub A67Setup()
    'Public stCoCPath As String
 
    Dim wkb As Workbook
    Dim rgRow As Range
    Dim vrRepTest As Variant
    'Call SetDepconDir       'Debug Only
    'Call SetOfficeNm        'Debug only, Set PV stCoCPath
    '-------------------------------------------------------------------
    '082605E Open the A67 file and see if the "Rep" field is in the new position
    '--------------------------------------------------------------------
    On Error Resume Next
    Set wkb = Workbooks(stCoCName)
    If wkb Is Nothing Then
        Set wkb = Workbooks.Open(Filename:=stCoCPath)
        stCoCName = ThisWorkbook.Name   'Set Public Variable
    End If
    Workbooks(wkb.Name).Worksheets("Sheet1").Activate
    Set rgRow = Range("A1:T1")
    vrRepTest = rgRow.Cells(1, 13).Value
    If vrRepTest = "Rep" Then
        blCoCUpdated = True
    Else
        blCoCUpdated = False
    End If
    wkb.Close
End Sub
Sub CoCCopy()   ':090515
    '------------------------------------------------------------------------------------
    'Append the Overview Report pointed to by Workbook Oject Wkb4. This will be either
    'CoC_Office.2004(Original CoC + new fields/old grants) or COC_Office.2005 (2004+ 2005)
    '------------------------------------------------------------------------------------
    Dim i As Long, j As Long, n As Long
    Dim wkb As Workbook
    Dim rgCOC As Range, rgA67 As Range
    Dim t As Single
    Dim lLastCoCRow As Long
    Dim lLastA67Row As Long
    Dim vrCoCArray() As Variant
    Dim vrA67Array() As Variant
    Dim stA67Address As String
 
    If blAbort Then Exit Sub
    If Not blCoCReports Then
        Debug.Print "CoCCopy     -No CoC Overview Reports to process - EXIT"
        Exit Sub
    End If
    t = Timer
    '--------- for Debug purposes only ----------
    'stCoCName = "CoC_Massachusetts.xls"
    'stA67WkbName = "A67R1.Massachusetts.08312005.xls"
    '--------------------------------------------
    Application.ScreenUpdating = False
    Set Wkb4 = Workbooks.Open(Filename:=stCoCPath)
    Workbooks(Wkb4.Name).Worksheets("Sheet1").Activate
    Set rgCOC = Range("$A$1").CurrentRegion
    lLastCoCRow = rgCOC.Rows.Count
    '---------Set CoC Array = to the CoC Data --------------------------
    vrCoCArray = rgCOC.Value
    '--------------Create A67 Array to same size as CoC Array-----------
    ReDim vrA67Array(1 To lLastCoCRow, 1 To 38)
    '--------------Copy the CoC Array to the A67 Array in A67 Format----
    For i = 1 To lLastCoCRow
        '---A67 Array-------CoC Array-----------'A67 Field Name-----
        vrA67Array(i, 1) = vrCoCArray(i, 4)     'LOCCS_Project#
        vrA67Array(i, 3) = vrCoCArray(i, 17)    'Year
        vrA67Array(i, 4) = vrCoCArray(i, 15)    'State
        vrA67Array(i, 5) = vrCoCArray(i, 18)    'Program
        vrA67Array(i, 6) = vrCoCArray(i, 8)     'CoC Applicant Name
        vrA67Array(i, 7) = "Not in LOCCS-From CoC Overview Report"   'GRANTEE_TID
        vrA67Array(i, 10) = vrCoCArray(i, 6)    'LOCCS_Term
        vrA67Array(i, 14) = vrCoCArray(i, 12)   'LOCCS Authorized
        vrA67Array(i, 15) = 0                   'LOCCS Disbursed
        vrA67Array(i, 16) = vrCoCArray(i, 12)   'LOCCS Balance
        vrA67Array(i, 17) = dtRptDate           'LOCC_RPTDATE
        vrA67Array(i, 18) = vrCoCArray(i, 19)   'BLICODES
        'vrA67Array(i, 21) = "FALSE"             'Slow Spender
        vrA67Array(i, 23) = "TRUE"              'ActiveGrant
        vrA67Array(i, 24) = vrCoCArray(i, 2)   'CoC_Code(MA00) 'FIX:090515
        vrA67Array(i, 25) = vrCoCArray(i, 1)    'CoCPID
        vrA67Array(i, 26) = vrCoCArray(i, 5)    'CoCProgram Code
        vrA67Array(i, 27) = vrCoCArray(i, 7)    'CoCComponent
        vrA67Array(i, 28) = vrCoCArray(i, 6)    'CoC Term
        vrA67Array(i, 29) = vrCoCArray(i, 8)    'CoC Applicant Name
        vrA67Array(i, 30) = vrCoCArray(i, 9)    'CoC Sponsor
        vrA67Array(i, 31) = vrCoCArray(i, 10)   'CoC Project Name
        vrA67Array(i, 32) = vrCoCArray(i, 12)   'CoC Award
        vrA67Array(i, 33) = vrCoCArray(i, 16)   'CoC Continuum Name
        vrA67Array(i, 34) = vrCoCArray(i, 20)   'Status
        vrA67Array(i, 35) = vrCoCArray(i, 13)   'Rep
        vrA67Array(i, 36) = vrCoCArray(i, 21)   'User1
        vrA67Array(i, 37) = vrCoCArray(i, 22)   'User2
        vrA67Array(i, 38) = vrCoCArray(i, 23)   'User3
    Next i
    If wkb2 Is Nothing Then
        Set wkb2 = Workbooks.Open(Filename:=stA67FullNm)
    End If
        Workbooks(wkb2.Name).Worksheets("LOCCS_ALL").Activate
    With ActiveSheet
        '-----------Find the end of Data in the A67 Worksheet---------------
        Set rgA67 = Range("A1").End(xlDown).Offset(1, 0) 'Find the first empty cell
        stA67Address = rgA67.Address
        '---------------------------------------------------------------
        'Create region in A67 file that is = to the A67 Array then copy
        'Array data to that region.
        '---------------------------------------------------------------
        Range(stA67Address).Resize(lLastCoCRow, 38).Value = vrA67Array
        .UsedRange      'Reset the last cell
    End With
    Workbooks(Wkb4.Name).Close SaveChanges:=True
    Debug.Print "    CoCCopy", , Format(Timer - t, "#0.#00"), "Append the CoC Overview Report(duplicate records here)"
End Sub
Sub CoC_A67Merge() 'Tested 9/18/05. DID NOT SPEED UP ON CoCMerge Version without array
    Dim rgDB As Range, rgMyRange As Range
    Dim i As Long, j As Long, k As Long
    Dim lRows As Long, lRwCoC As Long, lColCoC As Long
    Dim mystuff As Variant
    Dim CurrentProject As Variant, NextProject As Variant
    Dim rgFoundCell As Range
    Dim wkb As Workbook
    Dim fs As Variant
    Dim t As Single
    Dim vrA67Array() As Variant
    Dim stA67Address As String
    t = Timer
    'stA67WkbName = "A67R1.Massachusetts.08312005.xls"
    Application.ScreenUpdating = False
    Workbooks(stA67WkbName).Worksheets("LOCCS_ALL").Activate
    With ActiveSheet
        .UsedRange  'Reset the last cell
        Set rgDB = Range("$A1").CurrentRegion
        rgDB.Select
        '----------------Sort so that duplicates are grouped---------------------
        Selection.Sort Key1:=Range("$A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        .UsedRange
    End With
    vrA67Array = rgDB.Value
    For i = 1 To rgDB.Rows.Count - 1
        If vrA67Array(i, 1) = vrA67Array(i + 1, 1) Then
            If IsEmpty(vrA67Array(i, 2)) = False And IsEmpty(vrA67Array(i + 1, 2)) = False Then
            'Duplicate LOCCS record found. Select the empty record and mark it for deletion
                If (vrA67Array(i, 14) = 0) Then
                    vrA67Array(i, 13) = "TRUE"          'Flag record for deletion
                ElseIf (vrA67Array(i + 1, 14) = 0) Then
                    vrA67Array(i + 1, 13) = "TRUE"      'Flag record for deletion
                End If
            Else
                vrA67Array(i, 24) = vrA67Array(i + 1, 24) 'CoCName
                vrA67Array(i, 25) = vrA67Array(i + 1, 25) 'PIN
                vrA67Array(i, 26) = vrA67Array(i + 1, 26) 'CoCProgram Code
                vrA67Array(i, 27) = vrA67Array(i + 1, 27) 'CoCComponent
                vrA67Array(i, 28) = vrA67Array(i + 1, 28) 'CoC Term
                vrA67Array(i, 29) = vrA67Array(i + 1, 29) 'CoC Applicant Name
                vrA67Array(i, 30) = vrA67Array(i + 1, 30) 'CoC Sponsor
                vrA67Array(i, 31) = vrA67Array(i + 1, 31) 'CoC Project Name
                vrA67Array(i, 32) = vrA67Array(i + 1, 32) 'CoC Award
                vrA67Array(i, 33) = vrA67Array(i + 1, 33) 'CoC Continuum Name
                vrA67Array(i, 34) = vrA67Array(i + 1, 34) 'Status
                vrA67Array(i, 35) = vrA67Array(i + 1, 35) 'Rep
                vrA67Array(i, 36) = vrA67Array(i + 1, 36) 'User1
                vrA67Array(i, 37) = vrA67Array(i + 1, 37) 'User2
                vrA67Array(i, 38) = vrA67Array(i + 1, 38) 'User3
                vrA67Array(i, 13) = "FALSE"               'Flag record for retention
                vrA67Array(i + 1, 13) = "TRUE"              'Flag record for deletion
            End If
            End If
    Next i
    With ActiveSheet
        'Create region in A67 file that is = to the A67 Array then copy
        'Array data to that region.
        Range("A1").CurrentRegion.Value = vrA67Array
        '.UsedRange      'Reset the last cell
    End With
End Sub
Sub TestAll()
    blTestAll = True
    ReDim vTestAllArray(1 To 30, 1 To 8)
 
    Call SetButtonsArray
    iButtonNmbr = 1
    Call Buttons
    iButtonNmbr = 2
    Call Buttons
    iButtonNmbr = 3
    'GoTo subexit:
    Call Buttons
    iButtonNmbr = 4
    Call Buttons
    iButtonNmbr = 5
    Call Buttons
    iButtonNmbr = 6
    Call Buttons
    iButtonNmbr = 8
    Call Buttons
    iButtonNmbr = 9
    Call Buttons
    iButtonNmbr = 10
    Call Buttons
    iButtonNmbr = 11
    Call Buttons
    iButtonNmbr = 12
    Call Buttons
    iButtonNmbr = 13
    Call Buttons
    iButtonNmbr = 14
    Call Buttons
    iButtonNmbr = 15
    Call Buttons
    iButtonNmbr = 16
    Call Buttons
    iButtonNmbr = 17
    Call Buttons
    iButtonNmbr = 18
    Call Buttons
    iButtonNmbr = 19
    Call Buttons
    iButtonNmbr = 20
    Call Buttons
    iButtonNmbr = 21
    Call Buttons
'subexit:
    Call TestAll_Summary
    blTestAll = False
End Sub
Sub TestAll_Summary()
    'Public vTestAllArray() As Variant
    Dim i As Integer
    Dim j As Integer
 
    '---------This line for debug purposes only-----------------------
    'ReDim vTestAllArray(1 To 30, 1 To 8)
 
    stWkb3Name = "Testall.xls"
    Workbooks.Add
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=stWkb3Name  'Use Name created from last filter
    Application.DisplayAlerts = True
    Set wkb3 = Workbooks(stWkb3Name)     'Set Public Variable with filter output file
 
    vTestAllArray(1, 1) = "ButtonNmbr"
    vTestAllArray(8, 1) = 7
    vTestAllArray(1, 2) = "Report Name"
    vTestAllArray(1, 3) = "Grant Count"
    vTestAllArray(1, 4) = "Award Totals"
    vTestAllArray(1, 5) = "Expenditures"
    vTestAllArray(1, 6) = "Balance Totals"
    vTestAllArray(1, 7) = "Timer"
    vTestAllArray(1, 8) = ""
    With ActiveSheet
        Range("A1").Resize(30, 8).Value = vTestAllArray
        .UsedRange      'Reset the last cell
        .Cells(1, 1).EntireColumn.ColumnWidth = 4
        .Cells(1, 1).EntireColumn.HorizontalAlignment = xlCenter
        .Cells(1, 2).EntireColumn.ColumnWidth = 38
        .Cells(1, 3).EntireColumn.ColumnWidth = 6
        .Cells(1, 3).EntireColumn.HorizontalAlignment = xlCenter
        .Cells(1, 4).EntireColumn.ColumnWidth = 16
        .Cells(1, 5).EntireColumn.ColumnWidth = 16
        .Cells(1, 6).EntireColumn.ColumnWidth = 16
        .Cells(1, 6).EntireColumn.ColumnWidth = 16
        .Cells(1, 7).EntireColumn.ColumnWidth = 8
        .Cells(1, 7).EntireColumn.HorizontalAlignment = xlCenter
        .UsedRange      'Reset the last cell
    End With
    With Range("A1:G1")
        .WrapText = True
        .Font.Bold = True
        .RowHeight = 24.75
        .VerticalAlignment = xlTop
        .HorizontalAlignment = xlCenter
        .Font.Bold = True
        .Interior.ColorIndex = 19
        .Interior.Pattern = xlSolid
    End With
        Range("A1:H22").Borders(xlInsideVertical).LineStyle = xlContinuous
        Range("A1:G23").Borders(xlInsideHorizontal).LineStyle = xlContinuous
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=stWkb3Name  'Use Name created from last filter
    Application.DisplayAlerts = True
End Sub
Sub ButtonsPrep()
    Dim t As Single
 
    t = Timer
    ReDim vTestAllArray(1 To 30, 1 To 8)
    blTestAll = False
    Call SetButtonsArray
    Debug.Print "ButtonsPrep", , Format(Timer - t, "#0.#00"); "  Call SetButtonsArray() to set button names"
End Sub
Sub NoSiteControl()
    Dim i As Long, j As Long, k As Long
    Dim rgMyRange As Range
    Dim rgDB As Range
    Dim stPgmCode As String
    Dim stPgmType As String
    Dim stBLICodes As String
    Dim t As Single
 
    t = Timer
    Application.ScreenUpdating = False
    Workbooks(wkb3.Name).Sheets("Sheet1").Activate
    Set rgMyRange = Range("$A1").CurrentRegion
    ActiveWorkbook.Names.Add Name:="Database", RefersToR1C1:=rgMyRange
    With Range("Database")
        If .Rows.Count = 1 Then
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count)
        Else
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count - 1)
        End If
    End With
 
    For i = 1 To rgDB.Rows.Count
        rgDB.Cells(i, 13).Value = 1
        stPgmCode = rgDB.Cells(i, 26).Value
        stPgmType = rgDB.Cells(i, 27).Value
        stBLICodes = rgDB.Cells(i, 18).Value
        If (stPgmCode = "SHP") And (stPgmType = "PH") Then
            If (stBLICodes = "") Then
                rgDB.Cells(i, 13).Value = 5
            ElseIf InStr(1, rgDB.Cells(i, 18).Value, "ACQ") > 0 Then
                rgDB.Cells(i, 13).Value = 2
            ElseIf InStr(1, rgDB.Cells(i, 18).Value, "REH") > 0 Then
                rgDB.Cells(i, 13).Value = 3
            ElseIf InStr(1, rgDB.Cells(i, 18).Value, "NC") > 0 Then
                rgDB.Cells(i, 13).Value = 4
            End If
        End If
    Next i
    Debug.Print "NoSiteControl", , Format(Timer - t, "#0.#00")
End Sub
Sub Covenants()
'---------------------------------------------------------------
'Enter with data to be examined already filtered to include only
'records that are not in LOCCS
'---------------------------------------------------------------
 
    Dim i As Long, j As Long, k As Long
    Dim rgMyRange As Range
    Dim rgDB As Range
    Dim stPgmCode As String
    Dim stPgmType As String
    Dim stBLICodes As String
    Dim t As Single
 
    t = Timer
    Application.ScreenUpdating = False
    Workbooks(wkb3.Name).Sheets("Sheet1").Activate
    Set rgMyRange = Range("$A1").CurrentRegion
    ActiveWorkbook.Names.Add Name:="Database", RefersToR1C1:=rgMyRange
    With Range("Database")
        If .Rows.Count = 1 Then
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count)
        Else
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count - 1)
        End If
    End With
 
    For i = 1 To rgDB.Rows.Count
        rgDB.Cells(i, 13).Value = 1 'Rows with no value will be deleted
        stPgmCode = rgDB.Cells(i, 26).Value
        stPgmType = rgDB.Cells(i, 27).Value
        stBLICodes = rgDB.Cells(i, 18).Value
        If (stPgmCode = "SHP") And (stPgmType = "PH") Then
            If (stBLICodes = "") Then
                rgDB.Cells(i, 13).Value = 5
            ElseIf InStr(1, rgDB.Cells(i, 18).Value, "ACQ") > 0 Then
                rgDB.Cells(i, 13).Value = 2
            ElseIf InStr(1, rgDB.Cells(i, 18).Value, "REH") > 0 Then
                rgDB.Cells(i, 13).Value = 3
            ElseIf InStr(1, rgDB.Cells(i, 18).Value, "NC") > 0 Then
                rgDB.Cells(i, 13).Value = 4
            End If
        End If
    Next i
    Debug.Print "Covenants", , Format(Timer - t, "#0.#00")
End Sub
Function Fn_iDuplicate() As Integer
'------------------------------------------------------------------------------
'Fn_iDuplicate()-Rev:112505 - Test the A67 Report for duplicate grantee numbers
'Enter function with Wkb2 Public Variable set to A67 Report Name
'Exit Function value = duplicate count
'------------------------------------------------------------------------------
    Dim i As Long
    Dim j As Long
    Dim lLastRow As Long
    Dim iDuplicate As Long
    Dim wkb As Workbook
    Dim stFileName As String
    Dim Rng As Range
    Dim stAddress As String
    Dim vGrantsArray As Variant
    Dim t As Single
    t = Timer
 
    '------------Use for debug only-----------------
    'Workbooks("A67R1.Massachusetts.10312005.xls").Activate
    'Set Wkb2 = ActiveWorkbook
    '-----------------------------------------------
 
    Workbooks(wkb2.Name).Sheets("LOCCS_ALL").Activate
    With ActiveSheet
        Range("$A1").Activate
        Set Rng = Range(ActiveCell, ActiveCell.End(xlDown))
        lLastRow = Rng.Rows.Count
    End With
    ReDim vGrantsArray(1 To lLastRow, 1 To 1)   'Need two-dimensional array even for one column
                                                'of array data because range has row-column dim.
    stAddress = Rng.Address
    vGrantsArray = Range(stAddress).Value   '---Copy column to array
    For j = 1 To lLastRow - 1   '----------Test for duplicates
        If vGrantsArray(j, 1) = vGrantsArray(j + 1, 1) Then
            iDuplicate = iDuplicate + 1
            'Debug.Print vGrantsArray(j, 1)
        End If
    Next j
    Fn_iDuplicate = iDuplicate
    'Debug.Print "Fn_iDuplicate", , Format((Timer - t), "#0.#00"); "Test for Duplicates, Duplicaate Count = ": Str (iDuplicate)
End Function
Sub Abort()
    Select Case iAbort
        Case Is = 1:    PublicMsg = ""
        Case Is = 2:    PublicMsg = ""
        Case Is = 3:    PublicMsg = "Fn_CoCAbort: No CoC Overview Report - Abort"
        Case Is = 4:    PublicMsg = "Fn_CoCAbort: No A67 Report - Abort"
        Case Is = 5:    PublicMsg = "BossnapsOpen: Duplicate records in A67 file - Abort"
        Case Is = 6:    PublicMsg = "SetWkbObjects: No A67 open - Restart BOSSNAPS"
        Case Is = 7:    PublicMsg = ""
        Case Is = 10:   PublicMsg = ""
    End Select
    MsgBox PublicMsg
End Sub
Sub CoCInit()
    Dim t As Single
 
    t = Timer
 
    Call SetDepconDir       'Set PV stDEPCONDir
    Call SetOfficeNm        'Set PV stCPDOffice, stCoCPath, stCoCName
    Call A67Setup           'Set PV stA67FullNm
    Call CoCUpdate          'Set PV/NM iCoCOfficeYear
    Call CoCNewYear         'Set PV iCoCNewYear
    Debug.Print "CoCInit", , Format((Timer - t), "#0.#00"), iCoCOfficeYear, "iAbort = "; iAbort
End Sub
Function Fn_CoCAbort() As Integer
 
    If stCoCPath = "" Then
        iAbort = 3
        Fn_CoCAbort = 3
    ElseIf stA67FullNm = "" Then
        iAbort = 4
        Fn_CoCAbort = 4
    End If
End Function
Sub CoCNewYear()
'--------------------------------------------------------------------------------------------
'Public Wkb5 As Workbook            'The "CoC2005+*.xls" New Overview Report Workbook object
'Copy/Append the new update to the end of the existing CoC_Office.200n.xls file
'NOTE - the new file does not have any manually entered user data
':061206 - Fixed duplicate 2005 project bug by searching for 2005 duplicates after merging with
'     CoC_Office.2004 file which has 2005 projects in LOCCS. Note - After sorting the record to
'     be duplicated is the first record.
'--------------------------------------------------------------------------------------------
    Dim fs As Variant
    Dim vafilename As Variant
    Dim rgDB As Range
    Dim Rng As Range
    Dim icount As Integer
    Dim i As Integer
    Dim j As Integer
    Dim iStartNm As Integer
    Dim iEndNm As Integer
    Dim iLength As Integer
    Dim stCoCReport As String
    Dim stNewName As String
    Dim stFindZZZ As String
    Dim stFoundCell As String
    Dim rgFoundCell As Range
    Dim t As Single
 
    t = Timer
 
    If Not blCoCReports Then
        Debug.Print "CoCNewYear", , , "No CoC Overview Reports to process - EXIT"
        Exit Sub
    End If
    If iCoCYear >= iCoCNewYear Then
        Debug.Print "    CoCNewYear", , "New CoC Report already copied/appended - EXIT"
        Exit Sub
    End If
 
    Set Wkb5 = Workbooks.Open(Filename:=stCoCNewYearPath)
    Workbooks(Wkb5.Name).Worksheets("Sheet1").Activate
    With ActiveSheet
        Range("$A2").CurrentRegion.Select
        Selection.Copy
    End With
    Set Wkb4 = Workbooks.Open(Filename:=stCoCPath)
    Workbooks(Wkb4.Name).Worksheets("Sheet1").Activate
    '-----------Paste the Clipboard to end of CoC report------------------
    With ActiveSheet
        Range("$D1").End(xlDown).Offset(1, -3).Select 'Find the first empty cell
        .Paste
        .UsedRange  'Reset the last cell
        Range("$A1").CurrentRegion.Select
        '----------------Sort so that duplicates are grouped---------------------
        Selection.Sort Key1:=Range("$D1"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    End With
    '--------Mark the duplicates as "ZZZ" in the Project# Field--------------
    With ActiveSheet
        Set rgDB = Range("D1", Range("D2").End(xlDown))
        For i = 2 To rgDB.Rows.Count    ':112906 fix for San Antonio extra header in row 2
                    For j = 1 To 20         'Delete up to 20 duplicates
                If rgDB.Cells(i, 1).Value = rgDB.Cells(i + j, 1).Value Then
                    rgDB.Cells(i, 1).Value = "ZZZ"
                'Debug.Print i, j, rgDB.Cells(i, 1), rgDB.Cells(i, j + 1)
                Else
                    Exit For
                End If
            Next j
        Next i
        '-----------Sort the database so the "ZZZ" records are grouped at end -----------
        Range("$A1").CurrentRegion.Select
        Selection.Sort Key1:=(Cells(1, 4)), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        Set Rng = Range("D1", Range("D1").End(xlDown))
        stFindZZZ = Rng.Address
        '------------Find the first "ZZZ" record ---------------------------------
        On Error GoTo NoDuplicates: ':062806 fix for "No Duplicates"
        Set rgFoundCell = Range(stFindZZZ).Find(what:="ZZZ")
        stFoundCell = rgFoundCell.Address
        '-------------------------------------------------------------------------------
        'Define a single range object that has all "ZZZ" records then delete the records
        '-------------------------------------------------------------------------------
        Range(stFoundCell, Range("D1").End(xlDown)).EntireRow.Delete
        .UsedRange
    End With
NoDuplicates:
    Err.Clear
    stNewName = Wkb4.Path + "\CoC_" + stCPDOffice + "." + Trim(Str(iCoCNewYear)) + ".xls"
    Wkb5.Close
    Wkb4.Close SaveChanges:=True
    Name stCoCPath As stNewName
    stCoCPath = stNewName
    Debug.Print "CoCNewYear", , Format((Timer - t), "#0.#00"), stNewName
End Sub
Sub BossnapsSetup()
    Dim t As Single
    Debug.Print "  Call BossnapssetuP()", , "Set Public Variables for  Sub BOSSNAPSOPEN()"
    t = Timer
    Call Format_ErrorWindow("Processing files - Please wait")
    Application.ScreenUpdating = False
    fmProgress.Show vbModeless
    fmProgress.pcProgress (2)
    ChDir (ThisWorkbook.Path)
    stMacroFullNm = ThisWorkbook.FullName       'Set Public Variable
    stMacroDir = ThisWorkbook.Path              'Set Public Variable
    stMacroNm = ThisWorkbook.Name               'Set Public Variable
    Call SetDepconDir   'stDEPCONDir = "" if no DEPCON Dir
    Call CreateMasterCoC    'If there is no master CoC use Annual CoC
    Call SetOfficeNm    'stCPDOffice from Overview Report
    Call A67Setup       'stA67Nm & blA67Updated & dtA67xlsDate from latest A67 file
    Call DepconSetup    'dtDepconDate & stDepconFileNm of newest ".bkp" files
    If (dtDepconDate > dtA67xlsDate) Then blNewDepcon = True
    fmProgress.pcProgress (10)
    Debug.Print "  BossnapsSetup", , Format((Timer - t), "#0.#00")
End Sub
Sub A67Select()
    Dim iDaysLate As Integer
    Dim stMsg1 As String
    Set wkb2 = Workbooks.Open(Filename:=stA67FullNm)
    Workbooks(wkb2.Name).Worksheets("LOCCS_ALL").Activate
    iDaysLate = DateDiff("d", dtA67xlsDate, Date) - 31
    If iDaysLate > 5 Then
        stMsg = "DEPCON FILES ARE " & Str(iDaysLate) & " DAYS LATE" & Chr(10) _
        & "Using existing EXCEL Report " & Chr(10) & stA67Nm & Chr(10) & "        SELECT ANY BUTTON"
    Else
        If Not blDepConDir Then
            stMsg1 = "NO DEPCON DIRECTORY" & Chr(10)
        Else
            stMsg1 = ""
        End If
        stMsg = stMsg1 & "No new A67 Reports - Using existing EXCEL Report " & Chr(10) & stA67Nm & Chr(10) _
        & "        SELECT ANY BUTTON"
    End If
End Sub
Sub B18_ProblemGrants()
    Debug.Print "B18_ProblemGrants()", ; "       Filter Problem Grants for all Programs"
    Debug.Print "   Call B18_rgDB3Setup()"
    Debug.Print "   Call B18_rgDB3Variables(i)"
    Debug.Print "   Call B18_OctRecapture(i)"
    Debug.Print "   Call B18_SiteControl(i)"
    Debug.Print "   Call B18_Covenants(i)"
    Debug.Print "   Call B18_EnvReview(i)"
    Debug.Print "   Call B18_SlowSpenderSHP(i)"
    Debug.Print "   Call B18_SlowSpenderSPC(i)"
    Debug.Print "   Call B18_SlowSpenderYB(i)"
 
    Dim i As Long
    Dim t As Single
    t = Timer
 
    Call SetWkbObjects  'Also sets PV iRptYear to A67 report year
    Call B18_rgDB3Setup
    For i = 1 To rgDB3.Rows.Count
        Call B18_rgDB3Variables(i)
        Call B18_OctRecapture(i)
        Call B18_SiteControl(i)
        Call B18_Covenants(i)
        Call B18_EnvReview(i)
        Call B18_SlowSpenderSHP(i)
        Call B18_SlowSpenderSPC(i)
        Call B18_SlowSpenderYB(i)
    Next i
    Debug.Print "B18_ProblemGrants", , Format((Timer - t), "#0.#00"); "  Total Run Time in Seconds"
End Sub
Sub B18_rgDB3Variables(i As Long)
'---------------------------------------------------
'Set the local variable names for the current record
'---------------------------------------------------
    '------------------Clear all the flags before processing this record-----------------
    blACQ = False: blREH = False: blNC = False: blNotinLOCCS = False: blCancel = False: _
    blClosed = False: blCovenant = False: blSiteControl = False: blEnvReview = False: blPH = False: _
    blBLICodes = False: blNoStartDate = False: blSHPNew = False: blSHPNew = False _
    : blSHPR = False: blSPCNew = False: blSPCR = False: blPRAW = False: blEffDate = False
 
    If IsNumeric(rgDB3.Cells(i, 7).Value) Then
        iYear = rgDB3.Cells(i, 7).Value
    Else
        iYear = 0
    End If
    stProgram = rgDB3.Cells(i, 5).Value
    If InStr(1, rgDB3.Cells(i, 12).Value, "Not in LOCCS") > 0 Then blNotinLOCCS = True
    If InStr(1, rgDB3.Cells(i, 14).Value, "No Data") > 0 Then blNoStartDate = True
    iMonthsElapsed = rgDB3.Cells(i, 17).Value
    rgDB3.Cells(i, 18).Value = 2            'Flag row for deletion as default
    dbAward = rgDB3.Cells(i, 20).Value
    dbSpent = rgDB3.Cells(i, 21).Value
    dbBalance = rgDB3.Cells(i, 22).Value
    stBLICodes = rgDB3.Cells(i, 19).Value
    If IsDate(rgDB3.Cells(i, 23).Value) Then dtRptDate = rgDB3.Cells(i, 23).Value   'Test "LOCCS_RptDate"
    If IsDate(rgDB3.Cells(i, 13).Value) Then blEffDate = True                       'Test "EFF_Date"
    If Len(stBLICodes) > 2 Then blBLICodes = True
    If InStr(1, stBLICodes, "ACQ") > 0 Then blACQ = True
    If InStr(1, stBLICodes, "REH") > 0 Then blREH = True
    If InStr(1, stBLICodes, "NC") > 0 Then blNC = True
    dbPctTermExp = rgDB3.Cells(i, 24).Value
    dbPctAwardSpent = rgDB3.Cells(i, 25).Value
    rgDB3.Cells(i, 26).Value = ""           '---Clear the "Slow Spender" Field
    rgDB3.Cells(i, 27).Value = ""           '---Clear the "Needs Covenant" Field
    rgDB3.Cells(i, 28).Value = ""           '---Clear the "Needs Env Review" Field
    stPgmCode = rgDB3.Cells(i, 6).Value    '-----SHP/SHPR/SPC/SPCR
    If stPgmCode = "SHP" Then blSHPNew = True
    If stPgmCode = "SHPR" Then blSHPR = True
    If stPgmCode = "SPC" Then blSPCNew = True
    If stPgmCode = "SPCR" Then blSPCR = True
    stPgmType = rgDB3.Cells(i, 30).Value    '-----PH/TH/SSO/TBRA/SBRA
    If stPgmType = "PH" Then blPH = True
    If stPgmType = "PRAW" Then blPRAW = True
    stStatus = rgDB3.Cells(i, 35).Value     '-----Cancelled;RC:Comp;SC:Comp
    If InStr(1, stStatus, ":Canc") > 0 Then blCancel = True
    If InStr(1, stStatus, ":Closed") > 0 Then blClosed = True
    If InStr(1, stStatus, "RC:Comp") > 0 Then blCovenant = True
    If InStr(1, stStatus, "SC:Comp") > 0 Then blSiteControl = True
    If InStr(1, stStatus, "ER:Comp") > 0 Then blEnvReview = True
    rgDB3.Cells(i, 31).Value = ""    '---Clear the new "Oct Award Loss" field
    rgDB3.Cells(i, 32).Value = ""    '---Clear the new "Site Control" field
End Sub
Sub B18_rgDB3Setup()
    '------------------------------------------------------------
    'Select Five fields to be used for "Problem Grants"
    'Rename these five fields to their Problem Grants Description
    '------------------------------------------------------------
    Dim rgMyRange As Range
    Dim t As Single
 
    t = Timer
    Application.ScreenUpdating = False
    Workbooks(wkb3.Name).Sheets("Sheet1").Activate
    Set rgMyRange = Range("$A1").CurrentRegion
    rgMyRange.Cells(1, 26).Value = "Slow Spender"       'Was "SlowSpender"
    rgMyRange.Cells(1, 27).Value = "Needs Covenant"     'Was "Covenant"
    rgMyRange.Cells(1, 28).Value = "Needs Env Review"   'Was "ActiveGrant
    rgMyRange.Cells(1, 31).Value = "October Recapture"  'Was "CoCTerm"
    rgMyRange.Cells(1, 32).Value = "Needs Site Control" 'Was "CoCApplicant"
 
    ActiveWorkbook.Names.Add Name:="Database", RefersToR1C1:=rgMyRange
    With Range("Database")
        If .Rows.Count = 1 Then
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count)
        Else
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count - 1)
        End If
    End With
    'Debug.Print "B18_rgDB3Setup", , ,Format((Timer - t), "#0.#00")
End Sub
Sub B18_OctRecapture(i As Long)
 
    Dim stRecaptureDate As String
    Dim dtRecaptureDate As Date
 
    stRecaptureDate = "10/1/" + CStr(iYear + 2)
    dtRecaptureDate = CVDate(stRecaptureDate)
 
    '------------------- Test for Grant Loss in October -----------------------
        If blCancel Then Exit Sub
        If blNotinLOCCS Then
            'If iRptYear - iYear > 1 Then        'Second year not in LOCCS
            If dtRptDate > dtRecaptureDate Then
                '-------Grant has already been recaptured - ignore-----------
            ElseIf iRptYear - iYear > 1 Then
                '-------Grant is in second year and will be recaptured 10/1/200x
                rgDB3.Cells(i, 31).Value = True
                rgDB3.Cells(i, 18).Value = 1
            End If
        End If
End Sub
Sub B18_SiteControl(i As Long)
    If blCancel Or blSiteControl Then Exit Sub
    If blNotinLOCCS And blSHPNew And blPH And blBLICodes Then
        If (blACQ Or blREH Or blNC) Then
            rgDB3.Cells(i, 32).Value = True
            rgDB3.Cells(i, 18).Value = 1
        End If
    ElseIf blNotinLOCCS And blSHPNew And blPH Then
        rgDB3.Cells(i, 32).Value = True
        rgDB3.Cells(i, 18).Value = 1
        rgDB3.Cells(i, 32).Interior.ColorIndex = 36
    End If
End Sub
Sub B18_Covenants(i As Long)
'------------------- Test for Restrictive Covenants -----------------------
    If blCancel Or blCovenant Then Exit Sub
    If blNotinLOCCS And blSHPNew And blPH And blBLICodes Then
        If (blACQ Or blREH Or blNC) Then
            rgDB3.Cells(i, 27).Value = True
            rgDB3.Cells(i, 18).Value = 1
        End If
    ElseIf blNotinLOCCS And blSHPNew And blPH Then
        rgDB3.Cells(i, 27).Value = True
        rgDB3.Cells(i, 18).Value = 1
        rgDB3.Cells(i, 27).Interior.ColorIndex = 36
    End If
 
End Sub
Sub B18_SlowSpenderSHP(i As Long)
 
    Dim blConstruction As Boolean
    Dim dtEffDate As Date
 
    If blACQ Or blNC Or blREH Then blConstruction = True
    If blCancel Then Exit Sub
    If (dbPctTermExp > 0.99) Or (dbPctAwardSpent > 0.995) Or (stProgram <> "SHP") Then
    '---------- Only analyze grants that have not expired with balances greater than 0
        Exit Sub
    ElseIf blNotinLOCCS And (iRptYear - iYear > 1) Then
    '-----------Not defined to LOCCS and more than 1 year old
        rgDB3.Cells(i, 26).Value = True
        rgDB3.Cells(i, 18).Value = 1
    ElseIf (Not blNotinLOCCS) And (blNoStartDate) And (iRptYear - iYear > 1) Then
    '-----------Defined to LOCCS and more than 1 year old without a Start Date
        rgDB3.Cells(i, 26).Value = True
        rgDB3.Cells(i, 18).Value = 3
    ElseIf (Not blNotinLOCCS) And (blNoStartDate) And (Not blConstruction) Then
    '---Defined to LOCCS with no Start Date and no Construction and more than 90
    '---from the date of this LOCCS Report---------------------------------------
        If blEffDate Then
            dtEffDate = rgDB3.Cells(i, 13).Value
            If DateDiff("d", dtEffDate, dtRptDate) > 120 Then
                rgDB3.Cells(i, 26).Value = True
                rgDB3.Cells(i, 18).Value = 5
            End If
        End If
    ElseIf (dbPctTermExp < 1) And (dbPctTermExp - dbPctAwardSpent > 0.25) Then
    '-----------Grant is defined to LOCCS and has not expired - Test for a 25% difference
        rgDB3.Cells(i, 26).Value = True
        rgDB3.Cells(i, 18).Value = 4
    End If
End Sub
Sub B18_SlowSpenderSPC(i As Long)
 
    Dim iTerm As Integer
 
    '-------- DO NOT TEST GRANTS THAT HAVE NOT BEEN DEFINED TO LOCCS OR ARE NOT SPC
    If stProgram <> "SPC" Or blNotinLOCCS Then
        Exit Sub
   '----------CHECK SPC RENEWALS THAT HAVE NOT EXPIRED FOR SLOW SPENDING
    ElseIf blSPCR And iMonthsElapsed < 3 Then
        Exit Sub
    ElseIf blSPCR And iMonthsElapsed > 12 Then
        Exit Sub
    ElseIf blSPCR And iMonthsElapsed > 3 And dbSpent = 0 Then
        rgDB3.Cells(i, 26).Value = True
        rgDB3.Cells(i, 18).Value = 3
    ElseIf (blSPCR And iMonthsElapsed > 3) And _
            (Abs(iMonthsElapsed / 12 - dbPctAwardSpent) > 0.25) Then
        rgDB3.Cells(i, 26).Value = True
        rgDB3.Cells(i, 18).Value = 4
    '---------TEST NEW SPC GRANTS THAT HAVE NOT EXPIRED FOR SLOW SPENDING-----------------
    ElseIf blSPCNew And iMonthsElapsed > 60 Then
        Exit Sub
    ElseIf blSPCNew And iMonthsElapsed > 3 And dbSpent = 0 Then
        rgDB3.Cells(i, 26).Value = True
        rgDB3.Cells(i, 18).Value = 5
    ElseIf blSPCNew And iMonthsElapsed < 60 And _
            (Abs(iMonthsElapsed / 60 - dbPctAwardSpent) > 0.25) Then
        rgDB3.Cells(i, 26).Value = True
        rgDB3.Cells(i, 18).Value = 6
    End If
End Sub
Sub B18_SlowSpenderYB(i As Long)
  '------Only analyze grants that have not expired with balances greater than 0
        If stProgram <> "YB" Or stProgram <> "HPAC" Then
            Exit Sub
        ElseIf (dbPctTermExp > 0.99) Or (dbPctAwardSpent > 0.995) Then
            Exit Sub
  '-----Grant is defined to LOCCS and has not expired - Test for a 25% difference
        ElseIf (dbPctTermExp < 1) And (dbPctTermExp - dbPctAwardSpent > 0.25) Then
            rgDB3.Cells(i, 26).Value = True
            rgDB3.Cells(i, 18).Value = 1
        End If
End Sub
Sub B18_EnvReview(i As Long)
    If blCancel Or blEnvReview Then Exit Sub
    If blNotinLOCCS And blSHPNew And blPH And blBLICodes Then
        If (blACQ Or blREH Or blNC) Then
            rgDB3.Cells(i, 28).Value = True
            rgDB3.Cells(i, 18).Value = 1
        End If
    ElseIf blNotinLOCCS And blSHPNew And blPH Then
        rgDB3.Cells(i, 28).Value = True
        rgDB3.Cells(i, 18).Value = 1
        rgDB3.Cells(i, 28).Interior.ColorIndex = 36
    End If
End Sub
Sub B18_CopyFormulas()
 
    Dim i As Long
 
    Debug.Print "B18_CopyFormulas()", ; "       Create Problem Grant Subtotals for each Program"
    If iButtonNmbr <> 18 Then Exit Sub
    Range("A1").Select
    i = Range(ActiveCell, ActiveCell.End(xlDown)).Rows.Count + 2
    Cells(i, 1).Select
    Selection.Copy
    Range(Cells(i, 4), Cells(i, 8)).Select
    ActiveSheet.Paste
End Sub
Sub B03_ExpwithBal()
    Dim i As Long
    Dim t As Single
    t = Timer
 
    Debug.Print "B03_ExpwithBal", ; "       Expired Projects with non-zero balances"
    Debug.Print "   Call B03_rgDB3Variables(i)"
    Debug.Print "   Call B03_SHP(i)"
    Debug.Print "   Call B03_SPC(i)"
    Debug.Print "   Call B03_YB(i)"
    Debug.Print "   Call B03_HOPWA(i)"
    Call SetWkbObjects  'Also sets PV iRptYear to A67 report year
    Call B03_rgDB3Setup
    For i = 1 To rgDB3.Rows.Count
        Call B03_rgDB3Variables(i)
        Call B03_SHP(i)
        Call B03_SPC(i)
        Call B03_YB(i)
        Call B03_HOPWA(i)
    Next i
    Debug.Print "B03_ExpWithBal", Format((Timer - t), "#0.#00"); "  Total Run Time in Seconds"
End Sub
Sub B03_rgDB3Setup()
    Dim rgMyRange As Range
    Dim t As Single
 
    'Debug.Print "B03_rgDB3Setup"
    t = Timer
    Application.ScreenUpdating = False
    Workbooks(wkb3.Name).Sheets("Sheet1").Activate
    Set rgMyRange = Range("$A1").CurrentRegion
    ActiveWorkbook.Names.Add Name:="Database", RefersToR1C1:=rgMyRange
    With Range("Database")
        If .Rows.Count = 1 Then
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count)
        Else
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count - 1)
        End If
    End With
    'Debug.Print "B18_rgDB3Setup", , ,Format((Timer - t), "#0.#00")
End Sub
Sub B03_rgDB3Variables(i)
'---------------------------------------------------
'Set the local variable names for the current record
'---------------------------------------------------
    'Debug.Print "B03_rgDB3Variables"
    blSHP = False: blSPC = False: blYB = False: blHOPWA = False
    If IsNumeric(rgDB3.Cells(i, 7).Value) Then
        iYear = rgDB3.Cells(i, 7).Value
    Else
        iYear = 0
    End If
    stProgram = rgDB3.Cells(i, 5).Value
    If stProgram = "SHP" Then
        blSHP = True
    ElseIf stProgram = "SPC" Then
        blSPC = True
    ElseIf stProgram = "YB" Then
        blYB = True
    ElseIf stProgram = "HPAC" Then
        blHOPWA = True
    End If
    If InStr(1, rgDB3.Cells(i, 12).Value, "Not in LOCCS") > 0 Then blNotinLOCCS = True Else blNotinLOCCS = False
    If InStr(1, rgDB3.Cells(i, 14).Value, "No Data") > 0 Then blNoStartDate = True Else blNoStartDate = False
    If IsNumeric(rgDB3.Cells(i, 15).Value) Then iTerm = rgDB3.Cells(i, 15).Value Else iTerm = 0
    iMonthsElapsed = rgDB3.Cells(i, 17).Value
    rgDB3.Cells(i, 18).Value = 2            'Flag row for deletion as default
    dbAward = rgDB3.Cells(i, 20).Value
    dbSpent = rgDB3.Cells(i, 21).Value
    dbBalance = rgDB3.Cells(i, 22).Value
    stBLICodes = rgDB3.Cells(i, 19).Value
    dbPctTermExp = rgDB3.Cells(i, 24).Value
    dbPctAwardSpent = rgDB3.Cells(i, 25).Value
    stPgmCode = rgDB3.Cells(i, 6).Value    '-----SHP/SHPR/SPC/SPCR
    If stPgmCode = "SPC" Then blSPCNew = True Else blSPCNew = False
    If stPgmCode = "SPCR" Then blSPCR = True Else blSPCR = False
    stStatus = rgDB3.Cells(i, 35).Value     '-----Cancelled;
    If InStr(1, stStatus, ":Canc") > 0 Then blCancel = True Else blCancel = False
End Sub
Sub B03_SHP(i As Long)
    'Debug.Print "B03_SHP(i As Long)"
    If blCancel Or blNotinLOCCS Or (Not blSHP) Then
        Exit Sub
    ElseIf (Not blNoStartDate) Then '-------Process all SHP records with a LOCCS "Start Date"
        If (iMonthsElapsed - iTerm > 3) Then rgDB3.Cells(i, 18).Value = 1
    Else
        rgDB3.Cells(i, 18).Value = 2
    End If
End Sub
Sub B03_SPC(i As Long)
    'Debug.Print "B03_SPC(i As Long)"
    If blCancel Or blNotinLOCCS Or (Not blSPC) Or (dbBalance < 0) Then
        Exit Sub
    ElseIf IsNumeric(rgDB3.Cells(i, 15).Value) Then 'User defined term in CoC_Office
        If (iMonthsElapsed > rgDB3.Cells(i, 15).Value) And (dbBalance > 0) Then
            rgDB3.Cells(i, 18).Value = 4    ':051306 Grant has expired
        End If
    ElseIf blSPCR And iMonthsElapsed > 15 And (dbBalance > 0.001) Then
        rgDB3.Cells(i, 18).Value = 5
    ElseIf blSPCNew And iMonthsElapsed > 63 And (dbBalance > 0.001) Then
        rgDB3.Cells(i, 18).Value = 6
    ElseIf iMonthsElapsed > 63 And dbBalance > 0.001 Then
        rgDB3.Cells(i, 18).Value = 7
    Else
        rgDB3.Cells(i, 18).Value = 2
    End If
End Sub
Sub B03_YB(i As Long)
    'Debug.Print "B03_YB(i As Long)"
    If Not blYB Then
        Exit Sub
    ElseIf iMonthsElapsed > 39 And dbBalance > 0.001 Then
        rgDB3.Cells(i, 18).Value = 1
    End If
End Sub
Sub B03_HOPWA(i As Long)
    'Debug.Print "B03_HOPWA(i As Long)"
    If Not blHOPWA Then
        Exit Sub
    ElseIf iMonthsElapsed > 39 And dbBalance > 0.001 Then
        rgDB3.Cells(i, 18).Value = 1
    End If
End Sub
Sub B17_SummaryReport()
'---------------------------------------------------------
'Set the workbook object variables for A67 Workbook
'---------------------------------------------------------
    Dim Rng As Range
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim PC As PivotCache
    Dim PT As PivotTable
    Dim PI As PivotItem
    Dim sYear As String
    Dim t As Single
    t = Timer
    'Debug.Print "   Sub Pivot_Tables - Call B17_ActiveGrantsAll()"
    Set Rng = Range("A1").CurrentRegion
    Rng.Name = "Wbk3Database"
 
    ActiveWorkbook.Worksheets.Add.Name = "Summary Report"
    Sheets("Summary Report").Select
    Set PC = ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
             SourceData:="Wbk3Database")
    Set PT = ActiveSheet.PivotTables.Add(PivotCache:=PC, _
    TableDestination:=Range("A3"))
    PT.SmallGrid = False
    PT.AddFields RowFields:=Array(Rng.Range("G1").Value), _
        ColumnFields:=Rng.Range("E1").Value, PageFields:=Rng.Range("C1").Value
    PT.PivotFields(Rng.Range("C1").Value).CurrentPage = "All"
    With PT.PivotFields(Rng.Range("E1").Value)
        .Orientation = xlDataField
        .NumberFormat = "0"
        '.Function = xlCount
    End With
    With Sheets("Summary Report").Range(Cells(1, 3), Cells(2, 8))
        .Merge
        .WrapText = True
        .Value = "To view detailed data select 'Database' Tab below.  " _
            + Chr(10) + "Enter 'Control M' to return to BOSSNAPS screen"
        .Font.ColorIndex = 3
        .Font.Bold = True
        .Name = "Arial"
        .Font.Size = 10
        .HorizontalAlignment = xlCenter
        .Interior.ColorIndex = 36
    End With
    Application.CommandBars("PivotTable").Visible = False
    Columns("A:A").ColumnWidth = 8
    Debug.Print "   B17_ActiveGrantsAll", Format((Timer - t), "#0.#00"); "  Summary Report Tab Cr"
End Sub
Sub PivotTables()
 
    Dim t As Single
 
    Debug.Print "PivotTables()", , ; "       Select a Pivot Table Subroutine"
    t = Timer
    Call SetWkbObjects
    '------------Exit if the report has zero rows ------------------------
    If (Range("A1").CurrentRegion.Rows.Count < 2) Then Exit Sub
 
    Select Case iButtonNmbr
        Case 1:         Call B01_SummaryReport          'SHP Renewals
        Case 2:         'SPC Renewals
        Case 4:         Call B04_SummaryReport          'Expired Grants with balances
        Case 8:         Call B08_SummaryReport          'Slow Spenders ':012106
        Case 12:        Call B12_SummaryReport          'History of Restrictive Covenants
        Case 17:        Call B17_SummaryReport          'Active Grants
        Case 18:        'Problem Grants by Rep
        Case 19:        Call B19_SummaryReport          'Grants Not Defined to LOCCS by State/REp
        Case 20:        Call B20_SummaryReport          'Grantee Count by State
        Case 23:        'Grants Needing Restrictive Covenants
    End Select
    'Debug.Print "PivotTables", , Format(Timer - t, "#0.#00"); "  Summary Report Tab Creation"
End Sub
Sub CopyTextBox_PT()
    Dim stTextboxRow As String
    Dim t As Single
    Dim i As Long
    t = Timer
    Call SetWkbObjects
    '----------Select the text box for this button
    Select Case iButtonNmbr
        Case 1:         stTextBoxNm = ""            'SHP Renewals
        Case 2:         stTextBoxNm = ""            'SPC Renewals
        Case 4:         stTextBoxNm = ""            'SHP/SPC/YB/HOPWA Expired with Balance
        Case 17:        stTextBoxNm = "Text Box 41"
        Case 18:        stTextBoxNm = ""            'Problem Grants by Rep
        Case 20:        stTextBoxNm = ""            ':062306 Grantee Count - All
        Case Else
            stTextBoxNm = ""
    End Select
    If stTextBoxNm = "" Then
        'Exit Sub
    Else
        '---------Copy the selected text box to the clipboard ----------------
        Application.ScreenUpdating = False
        wkb1.Activate
        Worksheets("Criteria").Activate
        ActiveSheet.Shapes(stTextBoxNm).Select
        Selection.Copy
        Worksheets("MACROS").Activate
        Application.ScreenUpdating = False
        '----------Select the button report and find the last data cell----------
        wkb3.Worksheets("Summary Report").Activate
        i = Cells(Rows.Count, "A").End(xlUp).Select
        Cells(ActiveCell.Row + 2, 1).Select
        '----------Past the textbox at the end of the Summary Report Pivot Table ----
        ActiveSheet.Paste
        Range("A1").Select
    End If
    Debug.Print "CopyTextBox_PT", Format(Timer - t, "#0.#00"); "  Summary Report Tab Instructions - "; stTextBoxNm
End Sub
Sub Buttons_SetCol()
    Dim rgRow1 As Range
    Dim i As Long
    Dim t As Single
    Dim A67AF As AutoFilter
    t = Timer
    wkb3.Activate
    Set rgRow1 = Range("A1:AL1")
    With rgRow1
        .Cells(1, 1).EntireColumn.ColumnWidth = 17                     'LOCCS_Nmbr
        .Cells(1, 2).EntireColumn.ColumnWidth = 8                       'PIN
        .Cells(1, 3).EntireColumn.ColumnWidth = 6                       'Rep
        .Cells(1, 4).EntireColumn.Hidden = True                         'LOCCS_Nmbr1
        .Cells(1, 5).EntireColumn.ColumnWidth = 8                       'Program
        .Cells(1, 6).EntireColumn.ColumnWidth = 7                      'CoCPgmCode
        .Cells(1, 7).EntireColumn.ColumnWidth = 6                       'Year
        .Cells(1, 8).EntireColumn.ColumnWidth = 6                       'State
        .Cells(1, 9).EntireColumn.ColumnWidth = 25                      'Grantee_Nm
        .Cells(1, 10).EntireColumn.ColumnWidth = 15                     'CoCSponsor
        .Cells(1, 11).EntireColumn.ColumnWidth = 15                     'CoCProjName
        .Cells(1, 12).EntireColumn.ColumnWidth = 12                     'Grantee_TID
        Range(Cells(1, 13), Cells(1, 14)).EntireColumn.ColumnWidth = 10 'EFF_DATE, Start_Date
        .Cells(1, 15).EntireColumn.ColumnWidth = 9                      'Term_months
        .Cells(1, 16).EntireColumn.ColumnWidth = 10                     'Exp_Date
        .Cells(1, 17).EntireColumn.Hidden = True                        'MonthsElapsed
        .Cells(1, 18).EntireColumn.ColumnWidth = 4                      'Activity
        .Cells(1, 19).EntireColumn.ColumnWidth = 15                     'BLI_Codes
        Range(Cells(1, 20), Cells(1, 22)).EntireColumn.ColumnWidth = 14 'Authorized,Disbursed,Balance
        .Cells(1, 23).EntireColumn.ColumnWidth = 10                     'LOCC_RptDate
        Range(Cells(1, 24), Cells(1, 28)).EntireColumn.ColumnWidth = 8 '%TermExpired,%AwardSpent,SlowSpender,ActiveGrant
        .Cells(1, 29).EntireColumn.ColumnWidth = 10                     'COC_Name
        .Cells(1, 30).EntireColumn.ColumnWidth = 6                      'CoCComponet
        .Cells(1, 31).EntireColumn.Hidden = True                        'CoCTerm
        .Cells(1, 23).EntireColumn.ColumnWidth = 10                     'LOCC_RptDate
        .Cells(1, 33).EntireColumn.Hidden = True                        'CoCAward
        .Cells(1, 34).EntireColumn.ColumnWidth = 6                      'CoCContName
        .Cells(1, 35).EntireColumn.ColumnWidth = 10                     'Status
        Range(Cells(1, 36), Cells(1, 38)).EntireColumn.ColumnWidth = 8  'User1,User2,User3
    End With
    fmProgress.pcProgress (30)
    Debug.Print "Buttons_SetCol", Format(Timer - t, "#0.#00"); "  Renew ColWidth & Hide columns"
End Sub
Sub B04_SummaryReport()
    Dim Rng As Range
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim PC As PivotCache
    Dim PT As PivotTable
    Dim PI As PivotItem
    Dim sYear As String
    Dim t As Single
    t = Timer
    'Debug.Print "   Sub Pivot_Tables - Call B04_ExpBalAll()"
    Set Rng = Range("A1").CurrentRegion
    Rng.Name = "Wbk3Database"
 
    ActiveWorkbook.Worksheets.Add.Name = "Summary Report"
    Sheets("Summary Report").Select
    Set PC = ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
             SourceData:="Wbk3Database")
    Set PT = ActiveSheet.PivotTables.Add(PivotCache:=PC, _
    TableDestination:=Range("A3"))
    PT.SmallGrid = False
    PT.AddFields RowFields:=Array(Rng.Range("I1").Value), ColumnFields:=Rng.Range("E1").Value, PageFields:=Rng.Range("C1").Value
    PT.PivotFields(Rng.Range("C1").Value).CurrentPage = "All"
    With PT.PivotFields("Balance")
        .Orientation = xlDataField
        .NumberFormat = "$#,###.00"
        .Function = xlSum
        .Caption = "Grantees with Expired Grants with +Balances for each Grantee/Program"
    End With
     With PT.PivotFields(Rng.Range("C1").Value)
        .Caption = "CPD Representative"
    End With
    With Sheets("Summary Report").Range(Cells(1, 3), Cells(2, 6))
        .Merge
        .WrapText = True
        .Value = "To view detailed data select 'Database' Tab below. " _
            + Chr(10) + "Enter 'Control M' to return to BOSSNAPS screen"
        .Font.ColorIndex = 3
        .Font.Bold = True
        .Name = "Arial"
        .Font.Size = 10
        .HorizontalAlignment = xlCenter
        .Interior.ColorIndex = 36
    End With
    ActiveWindow.SplitRow = 4
    ActiveWindow.FreezePanes = True
    'PT.PivotFields("Data").PivotItems("Sum of Authorized").Position = 2
    'PT.PivotFields("Grantee_Nm").Caption = "Grantee Name"
    Application.CommandBars("PivotTable").Visible = False
    Columns("A:A").ColumnWidth = 50
    Debug.Print "   B04_ExpBalALL", Format((Timer - t), "#0.#00"); "  Summary Report Tab"
End Sub
Sub B18_SummaryReport()
    Dim Rng As Range
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim PC As PivotCache
    Dim PT As PivotTable
    Dim PI As PivotItem
    Dim sYear As String
    Dim t As Single
    t = Timer
    'Debug.Print "   Sub Pivot_Tables - Call B04_ExpBalAll()"
    Set Rng = Range("A1").CurrentRegion
    Rng.Name = "Wbk3Database"
 
    ActiveWorkbook.Worksheets.Add.Name = "Summary Report"
    Sheets("Summary Report").Select
    Set PC = ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
             SourceData:="Wbk3Database")
    Set PT = ActiveSheet.PivotTables.Add(PivotCache:=PC, _
    TableDestination:=Range("A3"))
    PT.SmallGrid = False
    PT.AddFields RowFields:=Array("CoC_Name"), ColumnFields:="Program", PageFields:="Rep"
    'PT.PivotFields("LOCCS_Nmbr").Orientation = xlDataField
    PT.PivotFields("Rep").CurrentPage = "All"
    With PT.PivotFields("LOCCS_Nmbr")
        .Orientation = xlDataField
        .NumberFormat = "0"
        .Function = xlCount
        .Caption = "Count of Slow Spenders by Continuum/Rep"
    End With
     With PT.PivotFields("Grantee_Nm")
        .Caption = "Grantee Name"
    End With
     With PT.PivotFields("Rep")
        .Caption = "CPD Representative"
    End With
    With Sheets("Summary Report").Range(Cells(1, 3), Cells(2, 6))
        .Merge
        .WrapText = True
        .Value = "To view detailed data select 'Database' Tab below.  " _
            + Chr(10) + "Enter 'Control M' to return to BOSSNAPS screen"
        .Font.ColorIndex = 3
        .Font.Bold = True
        .Name = "Arial"
        .Font.Size = 10
        .HorizontalAlignment = xlCenter
        .Interior.ColorIndex = 36
    End With
    ActiveWindow.SplitRow = 4
    ActiveWindow.FreezePanes = True
    'PT.PivotFields("Data").PivotItems("Sum of Authorized").Position = 2
    'PT.PivotFields("Grantee_Nm").Caption = "Grantee Name"
    Application.CommandBars("PivotTable").Visible = False
    Columns("A:A").ColumnWidth = 50
    Debug.Print "   B04_ExpBalALL", Format((Timer - t), "#0.#00"); "  Summary Report Tab"
End Sub
Sub B08_SlowSpenderAll()
    Debug.Print "B08_SlowSpenderAll()", ; "       Filter Problem Grants for all Programs"
    Debug.Print "   Call B18_rgDB3Setup()"
    Debug.Print "   Call B18_rgDB3Variables(i)"
    Debug.Print "   Call B18_SlowSpenderSHP(i)"
    Debug.Print "   Call B18_SlowSpenderSPC(i)"
    Debug.Print "   Call B18_SlowSpenderYB(i)"
 
    Dim i As Long
    Dim t As Single
    t = Timer
 
    Call SetWkbObjects  'Also sets PV iRptYear to A67 report year
    Call B08_rgDB3Setup
    For i = 1 To rgDB3.Rows.Count
        Call B18_rgDB3Variables(i)
        Call B18_SlowSpenderSHP(i)
        Call B18_SlowSpenderSPC(i)
        Call B18_SlowSpenderYB(i)
    Next i
    Debug.Print "B18_Workloads", , Format((Timer - t), "#0.#00"); "  Total Run Time in Seconds"
End Sub
Sub B08_rgDB3Setup()
    Dim rgMyRange As Range
    Dim t As Single
 
    t = Timer
    Application.ScreenUpdating = False
    Workbooks(wkb3.Name).Sheets("Sheet1").Activate
    Set rgMyRange = Range("$A1").CurrentRegion
    rgMyRange.Cells(1, 26).Value = "Slow Spender"       'Was "SlowSpender"
 
    ActiveWorkbook.Names.Add Name:="Database", RefersToR1C1:=rgMyRange
    With Range("Database")
        If .Rows.Count = 1 Then
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count)
        Else
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count - 1)
        End If
    End With
    'Debug.Print "B18_rgDB3Setup", , ,Format((Timer - t), "#0.#00")
End Sub
Sub B08_SummaryReport()
    Dim Rng As Range
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim PC As PivotCache
    Dim PT As PivotTable
    Dim PI As PivotItem
    Dim sYear As String
    Dim t As Single
    t = Timer
    'Debug.Print "   Sub Pivot_Tables - Call B04_ExpBalAll()"
    Set Rng = Range("A1").CurrentRegion
    Rng.Name = "Wbk3Database"
 
    ActiveWorkbook.Worksheets.Add.Name = "Summary Report"
    Sheets("Summary Report").Select
    Set PC = ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
             SourceData:="Wbk3Database")
    Set PT = ActiveSheet.PivotTables.Add(PivotCache:=PC, _
    TableDestination:=Range("A3"))
    PT.SmallGrid = False
    PT.AddFields RowFields:=Array(Rng.Range("AC1").Value), _
    ColumnFields:=Rng.Range("E1").Value, PageFields:=Rng.Range("C1").Value
    PT.PivotFields("Rep").CurrentPage = "All"
    With PT.PivotFields(Rng.Range("A1").Value)
        .Orientation = xlDataField
        .NumberFormat = "0"
        .Function = xlCount
        .Caption = "Count of Slow Spenders by CoC/Rep"
    End With
     With PT.PivotFields(Rng.Range("C1").Value)
        .Caption = "CPD Representative"
    End With
    With Sheets("Summary Report").Range(Cells(1, 3), Cells(2, 8))
        .Merge
        .WrapText = True
        .Value = "To view detailed data select 'Database' Tab below." _
            + Chr(10) + "Enter 'Control M' to return to BOSSNAPS screen"
        .Font.ColorIndex = 3
        .Font.Bold = True
        .Name = "Arial"
        .Font.Size = 10
        .HorizontalAlignment = xlCenter
        .Interior.ColorIndex = 36
    End With
    ActiveWindow.SplitRow = 4
    ActiveWindow.FreezePanes = True
    'PT.PivotFields("Data").PivotItems("Sum of Authorized").Position = 2
    'PT.PivotFields("Grantee_Nm").Caption = "Grantee Name"
    Application.CommandBars("PivotTable").Visible = False
    Columns("A:A").ColumnWidth = 50
    Debug.Print "   B04_ExpBalALL", Format((Timer - t), "#0.#00"); "  Summary Report Tab"
End Sub
Sub B22_NoSiteControl()
    Debug.Print "B22_NoSiteControl()", ; "       Filter SHP Grants needing Site Control"
    Debug.Print "   Call B22_rgDB3Setup()"
    Debug.Print "   Call B18_rgDB3Variables(i)"
    Debug.Print "   Call B22_SiteControl(i)"
 
    Dim i As Long
    Dim t As Single
    t = Timer
 
    Call SetWkbObjects  'Also sets PV iRptYear to A67 report year
    Call B22_rgDB3Setup
    For i = 1 To rgDB3.Rows.Count
        Call B18_rgDB3Variables(i)
        Call B22_SiteControl(i)
    Next i
    Debug.Print "B22_NoSiteControl", , Format((Timer - t), "#0.#00"); "  Total Run Time in Seconds"
 
End Sub
Sub B22_rgDB3Setup()
    Dim rgMyRange As Range
    Dim t As Single
 
    t = Timer
    Application.ScreenUpdating = False
    Workbooks(wkb3.Name).Sheets("Sheet1").Activate
    Set rgMyRange = Range("$A1").CurrentRegion
    ActiveWorkbook.Names.Add Name:="Database", RefersToR1C1:=rgMyRange
    With Range("Database")
        If .Rows.Count = 1 Then
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count)
        Else
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count - 1)
        End If
    End With
    'Debug.Print "B22_rgDB3Setup", , ,Format((Timer - t), "#0.#00")
End Sub
Sub B22_SiteControl(i As Long)
    If blCancel Or blSiteControl Then Exit Sub
    If blNotinLOCCS And blSHPNew And blPH And blBLICodes Then
        If (blACQ Or blREH Or blNC) Then
            rgDB3.Cells(i, 18).Value = 1
        rgDB3.Range(Cells(i, 1), Cells(i, 38)).Interior.ColorIndex = 36
        End If
    ElseIf blNotinLOCCS And blSHPNew And blPH Then
        rgDB3.Cells(i, 18).Value = 1
        rgDB3.Range(Cells(i, 1), Cells(i, 38)).Interior.ColorIndex = 36
    End If
End Sub
Sub B23_NoResCovenant()
    Debug.Print "B23_NoResCovenant()", ; "       Filter SHP Grants needing Site Control"
    Debug.Print "   Call B22_rgDB3Setup()"
    Debug.Print "   Call B18_rgDB3Variables(i)"
    Debug.Print "   Call B23_Covenants(i)"
 
    Dim i As Long
    Dim t As Single
    t = Timer
 
    Call SetWkbObjects  'Also sets PV iRptYear to A67 report year
    Call B22_rgDB3Setup
    For i = 1 To rgDB3.Rows.Count
        Call B18_rgDB3Variables(i)
        Call B23_Covenants(i)
    Next i
    Debug.Print "B23_NoResCovenant", , Format((Timer - t), "#0.#00"); "  Total Run Time in Seconds"
End Sub
Sub B23_Covenants(i As Long)
'------------------- Test for Restrictive Covenants -----------------------
    If blCancel Or blCovenant Then Exit Sub
    If blNotinLOCCS And blSHPNew And blPH And blBLICodes Then
        If (blACQ Or blREH Or blNC) Then
            rgDB3.Cells(i, 18).Value = 1
        End If
    ElseIf blNotinLOCCS And blSHPNew And blPH Then
        rgDB3.Cells(i, 18).Value = 1
        rgDB3.Range(Cells(i, 1), Cells(i, 38)).Interior.ColorIndex = 36
    End If
 
End Sub
Sub B12_SummaryReport()
    Dim Rng As Range
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim PC As PivotCache
    Dim PT As PivotTable
    Dim PI As PivotItem
    Dim sYear As String
    Dim t As Single
    t = Timer
    'Debug.Print "   Sub B23_SummaryReport - Call B04_ExpBalAll()"
    Set Rng = Range("A1").CurrentRegion
    Rng.Name = "Wbk3Database"
 
    ActiveWorkbook.Worksheets.Add.Name = "Summary Report"
    Sheets("Summary Report").Select
    Set PC = ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
             SourceData:="Wbk3Database")
    Set PT = ActiveSheet.PivotTables.Add(PivotCache:=PC, _
    TableDestination:=Range("A3"))
    PT.SmallGrid = False
    PT.AddFields RowFields:=Array(Rng.Range("I1").Value), _
        ColumnFields:=Rng.Range("H1").Value, PageFields:=Rng.Range("C1").Value
    'PT.PivotFields("LOCCS_Nmbr").Orientation = xlDataField
    PT.PivotFields(Rng.Range("C1").Value).CurrentPage = "All"
    With PT.PivotFields(Rng.Range("A1").Value)
        .Orientation = xlDataField
        .NumberFormat = "0"
        .Function = xlCount
        .Caption = "Count of SHP Restrictive Covenants by State/Rep"
    End With
 
     With PT.PivotFields(Rng.Range("C1").Value)
        .Caption = "CPD Representative"
    End With
    With Sheets("Summary Report").Range(Cells(1, 3), Cells(2, 8))
        .Merge
        .WrapText = True
        .Value = "To view detailed data select 'Database' Tab below.  " _
            + Chr(10) + "Enter 'Control M' to return to BOSSNAPS screen"
        .Font.ColorIndex = 3
        .Font.Bold = True
        .Name = "Arial"
        .Font.Size = 10
        .HorizontalAlignment = xlCenter
        .Interior.ColorIndex = 36
    End With
    ActiveWindow.SplitRow = 4
    ActiveWindow.FreezePanes = True
    'PT.PivotFields("Data").PivotItems("Sum of Authorized").Position = 2
    'PT.PivotFields("Grantee_Nm").Caption = "Grantee Name"
    Application.CommandBars("PivotTable").Visible = False
    Columns("A:A").ColumnWidth = 50
    Debug.Print "   B12_SummaryReport", Format((Timer - t), "#0.#00"); "  Summary Report Tab"
End Sub
Sub B20_SummaryReport()     'Grantee Count by State
    Dim Rng As Range
    Dim Rng1 As Range
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim PC As PivotCache
    Dim PT As PivotTable
    Dim PI As PivotItem
    Dim sYear As String
    Dim iGrantCount As Integer
    Dim cGrantSum As Currency
    Dim iGranteeCount As Integer
    Dim stLastRow As String
 
    Dim t As Single
    t = Timer
    Set Rng = Range("A1").CurrentRegion
    Rng.Name = "Wbk3Database"
    '----Get the Grants Count and Grants Sum from the Subtotals row
    With Rng
        '----Get the Grants Count and Grants Sum from the Subtotals row
        iGrantCount = .Cells(Rng.Rows.Count + 2, 1).Value
        cGrantSum = .Cells(Rng.Rows.Count + 2, 20).Value
        '---Set up the Advanced Filter for the GranteeCount
        .Cells(1, 130).Value = "Grantee_TID"
        .Cells(2, 130).Value = "*"
        .Cells(1, 12).EntireColumn.Hidden = False
    End With
    '----Advanced Filter for the Grantee Count------------------------
    stLastRow = Range("L1").End(xlDown).Address
    Set Rng1 = Range("$L$1:" & stLastRow)
    Rng1.Activate
    With Rng1
        .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
        Workbooks(wkb3.Name).Worksheets("Sheet1").Range("DZ1:DZ3"), Unique:=True
        iGranteeCount = Rng1.Cells(Rng1.Rows.Count + 2, 1).Value
    End With
    '------------------------------------------------------------------
    ActiveWorkbook.Worksheets.Add.Name = "Summary Report"
    Sheets("Summary Report").Select
    '---Insert the Summary information as a Table---------------------
    Set Rng1 = ActiveSheet.Range("A1:B3")
    With Rng1
        .Cells(1, 1).Value = "Grantee Count = "
        .Cells(2, 1).Value = "Total Grants Count = "
        .Cells(3, 1).Value = "Total Grant Awards Sum = "
        .Cells(1, 2).Value = iGranteeCount
        .Cells(2, 2).Value = iGrantCount
        .Cells(3, 2).Value = cGrantSum
        .Cells(1, 1).EntireColumn.HorizontalAlignment = xlRight
        .Range(Cells(1, 1), Cells(3, 2)).Font.ColorIndex = 3
        .Range(Cells(1, 1), Cells(3, 2)).Font.Bold = True
        .Range(Cells(1, 1), Cells(3, 2)).Name = "Arial"
        .Range(Cells(1, 1), Cells(3, 2)).Font.Size = 12
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End With
    '----Set up the Pivot Table--------------------------------------------
    Set PC = ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
             SourceData:="Wbk3Database")
    Set PT = ActiveSheet.PivotTables.Add(PivotCache:=PC, _
    TableDestination:=Range("A7"))
    PT.SmallGrid = False
    PT.AddFields RowFields:=Array(Rng.Range("I1").Value), _
        PageFields:=Rng.Range("C1").Value
    With PT.PivotFields(Rng.Range("I1").Value)
        .Orientation = xlDataField
        .NumberFormat = "0"
        .Function = xlCount
        .Caption = "Count of Grants"
    End With
    With PT.PivotFields(Rng.Range("T1").Value)
        .Orientation = xlDataField
        .NumberFormat = "$#,###,##0"
        .Function = xlSum
        .Caption = "Sum of Grant Awards"
    End With
     With PT.PivotFields(Rng.Range("I1").Value)
        .Caption = "Grantee Name"
    End With
     With PT.PivotFields(Rng.Range("C1").Value)
        .Caption = "CPD Representative"
    End With
    '----Message box at top of screen to reference the database tab-----------
    With Sheets("Summary Report").Range(Cells(1, 4), Cells(2, 9))
        .Merge
        .WrapText = True
        .Value = "To view detailed data select 'Database' Tab below.  " _
            + Chr(10) + "Enter 'Control M' to return to BOSSNAPS screen"
        .Font.ColorIndex = 3
        .Font.Bold = True
        .Name = "Arial"
        .Font.Size = 10
        .HorizontalAlignment = xlCenter
        .Interior.ColorIndex = 36
    End With
    ActiveWindow.SplitRow = 4
    ActiveWindow.FreezePanes = True
    'PT.PivotFields("Data").PivotItems("Sum of Authorized").Position = 2
    'PT.PivotFields("Grantee_Nm").Caption = "Grantee Name"
    Application.CommandBars("PivotTable").Visible = False
    Columns("A:A").ColumnWidth = 50
    Columns("B:B").ColumnWidth = 20
    Debug.Print "   B20_SummaryReport", Format((Timer - t), "#0.#00"); "  Summary Report Tab"
End Sub
Sub B19_SummaryReport()
    Dim Rng As Range
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim PC As PivotCache
    Dim PT As PivotTable
    Dim PI As PivotItem
    Dim sYear As String
    Dim t As Single
    t = Timer
    Set Rng = Range("A1").CurrentRegion
    Rng.Name = "Wbk3Database"
 
    ActiveWorkbook.Worksheets.Add.Name = "Summary Report"
    Sheets("Summary Report").Select
    Set PC = ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
             SourceData:="Wbk3Database")
    Set PT = ActiveSheet.PivotTables.Add(PivotCache:=PC, _
    TableDestination:=Range("A3"))
    PT.SmallGrid = False
    PT.AddFields RowFields:=Array(Rng.Range("A1").Value), _
        ColumnFields:=Rng.Range("H1").Value, PageFields:=Rng.Range("C1").Value
    'PT.PivotFields("LOCCS_Nmbr").Orientation = xlDataField
    PT.PivotFields("Rep").CurrentPage = "All"
    With PT.PivotFields(Rng.Range("A1").Value)
        .Orientation = xlDataField
        .NumberFormat = "0"
        .Function = xlCount
        .Caption = "Count of Grants Not Defined to LOCCS by Rep/State"
    End With
     With PT.PivotFields(Rng.Range("C1").Value)
        .Caption = "CPD Representative"
    End With
    With Sheets("Summary Report").Range(Cells(1, 3), Cells(2, 8))
        .Merge
        .WrapText = True
       .Value = "To view detailed data select 'Database' Tab below.  " _
            + Chr(10) + "Enter 'Control M' to return to BOSSNAPS screen"
        .Font.ColorIndex = 3
        .Font.Bold = True
        .Name = "Arial"
        .Font.Size = 10
        .HorizontalAlignment = xlCenter
        .Interior.ColorIndex = 36
    End With
    ActiveWindow.SplitRow = 4
    ActiveWindow.FreezePanes = True
    'PT.PivotFields("Data").PivotItems("Sum of Authorized").Position = 2
    'PT.PivotFields("Grantee_Nm").Caption = "Grantee Name"
    Application.CommandBars("PivotTable").Visible = False
    Columns("A:A").ColumnWidth = 50
    Debug.Print "   B19_SummaryReport", Format((Timer - t), "#0.#00"); "  Summary Report Tab"
End Sub
Sub B01_SummaryReport()
    Dim Rng As Range
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim PC As PivotCache
    Dim PT As PivotTable
    Dim PI As PivotItem
    Dim sYear As String
    Dim t As Single
    t = Timer
    Set Rng = Range("A1").CurrentRegion
    Rng.Name = "Wbk3Database"
 
    ActiveWorkbook.Worksheets.Add.Name = "Summary Report"
    Sheets("Summary Report").Select
    Set PC = ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
             SourceData:="Wbk3Database")
    Set PT = ActiveSheet.PivotTables.Add(PivotCache:=PC, _
    TableDestination:=Range("A3"))
    PT.SmallGrid = False
    PT.AddFields RowFields:=Array(Rng.Range("A1").Value), PageFields:=Rng.Range("AH1").Value
    PT.PivotFields(Rng.Range("AH1").Value).CurrentPage = "All"
    With PT.PivotFields(Rng.Range("BB1").Value)
        .Orientation = xlDataField
        .NumberFormat = "$#,##0"
        .Function = xlSum
        .Caption = "Annual Renewal"
    End With
    'With PT.PivotFields(rng.Range("AH1").Value)
    '    .Orientation = xlDataField
    '    .NumberFormat = "#0"
    '    .Function = xlCount
    '    .Caption = "Count"
    'End With
    With Sheets("Summary Report").Range(Cells(1, 3), Cells(2, 8))
        .Merge
        .WrapText = True
        .Value = "To view detailed data select 'Database' tab below .  "
        .Font.ColorIndex = 3
        .Font.Bold = True
        .Name = "Arial"
        .Font.Size = 10
        .HorizontalAlignment = xlCenter
        .Interior.ColorIndex = 36
    End With
    ActiveWindow.SplitRow = 4
    ActiveWindow.FreezePanes = True
    'PT.PivotFields("Data").PivotItems("Sum of Authorized").Position = 2
    'PT.PivotFields("Grantee_Nm").Caption = "Grantee Name"
    Application.CommandBars("PivotTable").Visible = False
    Columns("A:A").ColumnWidth = 50
    Debug.Print "   B01_SummaryReport", Format((Timer - t), "#0.#00"); "  Summary Report Tab"
End Sub
Sub B01_SHPRenewals()
    Debug.Print "   B01_SHPRenewals()", ; "       Filter SHP Grants needing Site Control"
    Debug.Print "      Call B01_rgDB3Variables(i)"
    Debug.Print "      Call B01_TagRenewals(i)"
    Debug.Print "      Call B01_CalculateARA(i)"
    Dim i As Long
    Dim t As Single
    t = Timer
    Call SetWkbObjects  'Also sets PV iRptYear to A67 report year
    Call B22_rgDB3Setup
    vaSHPRenewals = rgDB3       '-----:090429 Fix for Speed Problem
    For i = 1 To rgDB3.Rows.Count
        Call B01_rgDB3Variables(i)
        Call B01_TagRenewals(i)
        Call B01_CalculateARA(i)
    Next i
    rgDB3 = vaSHPRenewals    '-----:090429 Fix for Speed Problem
    Call B01_CoCArrayInit
    Call B01_CoCContNames
    Debug.Print "   B01_SHPRenewals", Format((Timer - t), "#0.#00"); "  Total Run Time in Seconds"
End Sub
Sub B01_rgDB3Variables(i As Long)
 
    Dim ifield As Integer
    Dim iSHPYear As Integer
 
    If i = 35 Then
        'Debug.Print i
    End If
 
'---------------------------------------------------
'Set the local variable names for the current record
'---------------------------------------------------
    Call DB3_ResetBooleans  'Reset all Booleans
    For ifield = 1 To 54
        If ifield = 12 Then
            'Debug.Print i
        End If
        Select Case ifield
            Case 1  'Grant Number
                stGrantName = vaSHPRenewals(i, 1)   ':012706 Get grantID to PV for Fn_CoCTag
            Case 5  'Program SHP/SPC/YB/HOPWA
                stProgram = vaSHPRenewals(i, 5)
            Case 6  'CoC Program Code-SHP/SHPR/SPC/SPCR
                Call B01_Field06(i)
            Case 7  'Year
                If IsNumeric(vaSHPRenewals(i, 7)) Then
                    iYear = vaSHPRenewals(i, 7)
                Else
                    iYear = 0
                End If
            Case 12 'Grantee TAXID
                If InStr(1, vaSHPRenewals(i, 12), "Not in LOCCS") > 0 Then
                    blNotinLOCCS = True
                Else
                    blNotinLOCCS = False
                End If
            Case 13 'Grant Effective Date
                If IsDate(vaSHPRenewals(i, 13)) Then blEffDate = True Else blEffDate = False                      'Test "EFF_Date"
            Case 14 'Grant Start Date
                If InStr(1, vaSHPRenewals(i, 14), "No Data") > 0 Then
                    blNoStartDate = True
                    vaSHPRenewals(i, 14) = "No Start Date"
                Else
                    blNoStartDate = False
                End If
                If blNotinLOCCS Then vaSHPRenewals(i, 14) = "Not in LOCCS"
            Case 15 'Grant Term in years (Convert from "in months")
                '-----------------------------------------------------------------------
                'If a grant has been extended to make it eligible for renewal then you
                'Must use a "Round Down" to get a term in years for ARA calculation
                '-----------------------------------------------------------------------
                If IsNumeric(vaSHPRenewals(i, 15)) Then
                    iTerm = vaSHPRenewals(i, 15)
                Else
                    iTerm = 0
                End If
                '----Term in Months is now a valid number ( 0 or greater)
                If iTerm = 0 Then
                '----Exit this IF statement if iterm = 0
                ElseIf iTerm < 12 Then   '---Term in months less than 12
                    iTerm = 1   '----iTerm must be a multiple of 12 months for ARA Calculation
                Else    '----iTerm is 12 months or more
                '----Grant extensions change Exp Date but term must be rounded down
                    iTerm = (iTerm - iTerm Mod 12)  '---Set iTerm to a multiple of 12 months
                    iTerm = iTerm / 12  '---Set iTerm as a multiple of years
                End If
                vaSHPRenewals(i, 15) = iTerm
            Case 16 'Grant Expiration Date
                Call B01_Field16(i)
            Case 17 '"Activity" field-Use only as flag for marking fields for deletion
                vaSHPRenewals(i, 18) = -1   'Flag row for deletion as default
            Case 19 'BLICODES
                Call B01_field19(i)
            Case 20 'CoC Report "Award" field
                dbAward = vaSHPRenewals(i, 20)
            Case 23 'LOCCS Report Date field
                If IsDate(vaSHPRenewals(i, 23)) Then dtRptDate = vaSHPRenewals(i, 23)
            Case 29 'CoC Report "COC_Name" field set by parsing Grant Number field01
                vaSHPRenewals(i, 29) = Fn_CoCTag    'Get MA00, MA01, MA02, etc to field29
            Case 30 'CoC Report "CoCComponent" field-PH/TH/SSO/TBRA/SBRA
                stPgmType = vaSHPRenewals(i, 30)
                If stPgmType = "PH" Then blPH = True Else blPH = False
            Case 31 'CoC Report "CoC" Term field - Convert from "in months" to "in years"
                iCoCTerm = Round((vaSHPRenewals(i, 31) / 12), 0)
            Case 53 'Total of all renewable BLI fields-set to zero at this point
                vaSHPRenewals(i, 53) = 0
            Case 54 'Annual Renewal amount-set to zero at this point
                vaSHPRenewals(i, 54) = 0
        End Select
    Next ifield
End Sub
Sub B01_TagRenewals(i As Long)
 
    '--------------------------------------------
    'Grants with valid expiration dates
    '--------------------------------------------
    If blValidExpDate Then
        If Not blConstruction Then
            vaSHPRenewals(i, 18) = 1     'Grant expiring in selected year
        ElseIf blConstruction And blSuppServices Then
            vaSHPRenewals(i, 18) = 2    'Construction grant with a supportive services comp
        ElseIf blConstruction And Not blSuppServices Then
            vaSHPRenewals(i, 18) = -2    'Construction without supportive services
        Else
            vaSHPRenewals(i, 18) = -21
        End If
    '--------------------------------------------
    'Grants defined to LOCCS
    '--------------------------------------------
    ElseIf (Not blNotinLOCCS) Then  'Grant is defined to LOCCS
        If (iTerm < 1) Then
        '---In lOCCS but has no term data--------
            If (iYear + 1) + iCoCTerm = iExpYear Then
            'In LOCCS, No term data(waiting for BLI data entry)BUT has 12 month CoC term
                vaSHPRenewals(i, 18) = 3
            Else
                vaSHPRenewals(i, 18) = -3
            End If
        ElseIf blExpDate And (Not blValidExpDate) Then  'Grant does not expire in calendar year
                vaSHPRenewals(i, 18) = -31
        ElseIf blSHPR Then
        '------------------------------------------
        'In LOCCS, has term data, and is a Renewal
            If (iYear + 1) + iTerm = iExpYear Then
                vaSHPRenewals(i, 18) = 4    'In LOCCS, Expires next year
            Else
                vaSHPRenewals(i, 18) = -4
            End If
        ElseIf blSHPNew Then
        '------------------------------------------
        'In LOCCS, has term data and is a new grant
            If ((iYear + 1) + iTerm = iExpYear) And (Not blConstruction) Then
                vaSHPRenewals(i, 18) = 5
            Else
                vaSHPRenewals(i, 18) = -5
            End If
        Else
        '--------------------------------------------------------------------------
        'In LOCCS, has term data but does not fall into one of the above categories
                vaSHPRenewals(i, 18) = -6
        End If
    '--------------------------------------------
    'Grants NOT defined to LOCCS
    '--------------------------------------------
    ElseIf blNotinLOCCS Then    'Grant is not in LOCCS
        If (iYear + 2) < (iExpYear - 1) Then    'Grant has not been obligated within 2 years - Cancelled
            vaSHPRenewals(i, 18) = -71
        ElseIf (iYear + 1) + iCoCTerm = iExpYear Then
            vaSHPRenewals(i, 18) = 7
        Else
            vaSHPRenewals(i, 18) = -7
        End If
    End If
End Sub
 
Sub B02_CreateCoCFiles()         'Create a separate file for each Continuum Name
'
'Activate with "Control-Shift T" key
'
    Dim i As Long
    Dim icount As Long
    Dim k As Long
    Dim wks As Worksheet
    Dim wkb As Workbook
    Dim Rng As Range
    Dim stLastRow As String
    Dim stCriteria As String
    Dim stCoCID As String
    Dim stCoCContName As String
    Dim stCoCFileName As String
    Dim t As Single
    Dim blB01Active As Boolean
    Dim blWkb2Open As Boolean
    Dim stPrintArea As String
 
    Call SetWkbObjects  ':061606 Allow "CTL-SHIFT-T" when B01 file not active
 
    Application.ScreenUpdating = True
    t = Timer
    '------------------------Initialize variables if Program has been "RESET"-------
    iButtonNmbr = 1
    If wkb2 Is Nothing Then Call SetWkbObjects
    If stCoCArray(0, 1) = "" Then Call B01_CoCArrayInit
    '-----':061606 Allow files to be created by Ctl-Shift-t if B01 Report open------
    For Each wkb In Workbooks
        If InStr(1, wkb.Name, "Grants Eligible for Renewal.SPC") > 0 Then
            Set wkb3 = wkb
            wkb3.Activate
            If ActiveSheet.AutoFilterMode = True Then Range("$A$1").CurrentRegion.AutoFilter
            blB01Active = True
        ElseIf InStr(1, wkb.Name, "A67R1.") > 0 Then
            Set wkb2 = wkb
            blWkb2Open = True
        End If
    Next wkb
    If Not blWkb2Open Then
        MsgBox ("There is no A67R1 file open - restart Bossnaps")
        ThisWorkbook.Activate
        Exit Sub
    End If
    If Not blB01Active Then
        MsgBox ("You must run button SHP Annual Renewal Verification Test first")
        ThisWorkbook.Activate
        Exit Sub
    End If
    '----Get the Office Continuum Count
    For i = 0 To 100
        If stCoCArray(0, i) = "" Then Exit For
        k = k + 1
    Next i
    icount = k
    UserForm1.Show vbModeless
 
    For i = 0 To 100
        MsgPublic = "Processing file " & i & " of " & k
        UserForm1.DisplayMsg
        If stCoCArray(0, i) = "" Then GoTo ExitSub:
        Workbooks(wkb3.Name).Activate
        Worksheets(2).Copy before:=Worksheets(1)
        Set Rng = Range("A1").CurrentRegion
        With Rng
            .Cells(1, 29).EntireColumn.Hidden = False
        End With
        Set wks = Worksheets(1)
        stCoCID = Mid(stCoCArray(0, i), 1, 4)   'Get rid of ":" in name
        UserForm1.ListBox1.AddItem stCoCArray(1, i)
        stCoCContName = stCoCArray(1, i)
        stCriteria = "<>" & stCoCID
        wks.Name = stCoCID
        Rows(2).Insert
        Range("AC2").Value = "Temp"
        stLastRow = Range("AC1").End(xlDown).Address
        With ActiveSheet
            .UsedRange
            Set Rng = Range("$AC$2:" & stLastRow)
            Rng.AutoFilter Field:=29, Criteria1:=stCriteria
            Rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .UsedRange
        End With
        Worksheets(1).Copy
        If ActiveSheet.AutoFilterMode = True Then Range("$A$1").CurrentRegion.AutoFilter
        '-----042707 Set Print Area to include the subtotals line------
        Set Rng = Range("$A$1").SpecialCells(xlCellTypeLastCell)
        stPrintArea = "$A$1:" & Rng.Address
        ActiveSheet.PageSetup.PrintArea = stPrintArea
        '----042707 Clear the Columb AB Total Line and put a title in cell-------
        Set Rng = Range("BA1").End(xlDown).Offset(2)
        Rng.Value = "Annual Renewals Total"
        Rng.HorizontalAlignment = xlRight
        Rng.Font.Bold = True
        Application.ScreenUpdating = True
        Range("B2").Select
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=B01_Replace(stCoCContName & ".xls")
        ActiveWorkbook.Close
        Workbooks(wkb3.Name).Worksheets(stCoCID).Delete
    Application.DisplayAlerts = True
    Next i
ExitSub:
    MsgPublic = icount & " Files Generated in BOSSNAPS folder" & Chr(13) & " Click 'X' to EXIT this menu"
    UserForm1.DisplayMsg
    Debug.Print "B01_CreateCoCFiles", , Format(Timer - t, "#0.#00"); "  A67 First Pass Filter & Copy results to new workbook"
End Sub
Sub DB3_ResetBooleans()
    blACQ = False
    blBLICodes = False
    blCancel = False
    blClosed = False
    blConstruction = False
    blCovenant = False
    blEffDate = False
    blEnvReview = False
    blExpDate = False
    blNC = False
    blNoStartDate = False
    blNotinLOCCS = False
    blPH = False
    blPRAW = False
    blREH = False
    blSHPNew = False
    blSHPR = False
    blSiteControl = False
    blSPCNew = False
    blSPCR = False
    blSS = False
    blOPER = False
    blHMIS = False
    blLEASE = False
    blSuppServices = False
    blConstruction = False
    blValidExpDate = False
End Sub
Sub B01_Field06(i As Long)
    stPgmCode = rgDB3.Cells(i, 6).Value    '-----SHP/SHPR/SPC/SPCR
    If stPgmCode = "SHP" Then blSHPNew = True Else blSHPNew = False
    If stPgmCode = "SHPR" Then blSHPR = True Else blSHPR = False
    If stPgmCode = "SPC" Then blSPCNew = True Else blSPCNew = False
    If stPgmCode = "SPCR" Then blSPCR = True Else blSPCR = False
End Sub
Sub B01_Field16(i As Long)
 
    If IsDate(rgDB3.Cells(i, 16).Value) Then
        dtExpDate = rgDB3.Cells(i, 16).Value
        If dtExpDate < #1/1/1900# Then
            '---------Process the "01/00/00" date used for ACCESS---------------
            rgDB3.Cells(i, 16).Value = Str(iExpYear) & "-Estimated"
            blValidExpDate = False
        ElseIf dtExpDate > #1/1/1900# Then
            blExpDate = True
            If Month(dtExpDate) = 12 And Day(dtExpDate) = 31 Then   ':090827 Fix for exp date of 12/31/nn or 12/31nn-1
                If Year(dtExpDate) = iExpYear - 1 Or Year(dtExpDate) = iExpYear Then
                    blValidExpDate = True
                    rgDB3.Cells(i, 18).Value = 9
                End If
 
            'dtExpDate = DateAdd("d", 1, dtExpDate) 'Compensate for a 12/31/xx expiration date   ':090819 Fix for Boston
            ElseIf Year(dtExpDate) = iExpYear Then
                blValidExpDate = True
            Else
                blValidExpDate = False
            End If
        End If
    ElseIf blNotinLOCCS Then
        rgDB3.Cells(i, 16).Value = Str(iExpYear) & "-Estimated"
    ElseIf Not blNotinLOCCS And blNoStartDate Then
        rgDB3.Cells(i, 16).Value = Str(iExpYear) & "-Estimated"
    End If
End Sub
Sub B01_field19(i As Long)
    stBLICodes = rgDB3.Cells(i, 19).Value
    If InStr(1, stBLICodes, "ACQ") > 0 Then blACQ = True Else blACQ = False
    If InStr(1, stBLICodes, "REH") > 0 Then blREH = True Else blREH = False
    If InStr(1, stBLICodes, "NC") > 0 Then blNC = True Else blNC = False
    If blACQ Or blREH Or blNC Then blConstruction = True Else blConstruction = False
    If InStr(1, stBLICodes, "SS") > 0 Then blSS = True Else blSS = False
    If InStr(1, stBLICodes, "OPER") > 0 Then blOPER = True Else blOPER = False
    If InStr(1, stBLICodes, "HMIS") > 0 Then blHMIS = True Else blHMIS = False
    If InStr(1, stBLICodes, "LEASE") > 0 Then blLEASE = True Else blLEASE = False
    If blSS Or blHMIS Or blOPER Or blLEASE Then blSuppServices = True Else blSuppServices = False
End Sub
Sub B01_CalculateARA(i As Long)
':040806 Updated to correct reporting errors with construction projects
    Dim dbOper As Double
    Dim dbSS As Double
    Dim dbHMIS As Double
    Dim dbLease As Double
    Dim dbAdmin As Double
    Dim dbProjTotal As Double
    Dim dbARA As Double
    Dim dbSSTotal As Double
    Dim dbAuthorized As Double
    Dim dbCoCAward As Double
    Dim stGrant As String
    If vaSHPRenewals(i, 18) < 1 Then Exit Sub
 
    stGrant = vaSHPRenewals(i, 1)
    dbAuthorized = vaSHPRenewals(i, 20)
    dbCoCAward = vaSHPRenewals(i, 33)
    dbOper = vaSHPRenewals(i, 48)
    dbSS = vaSHPRenewals(i, 49)
    dbHMIS = vaSHPRenewals(i, 50)
    dbLease = vaSHPRenewals(i, 52)
    dbAdmin = vaSHPRenewals(i, 51)
 
    dbSSTotal = dbSS + dbOper + dbHMIS + dbLease
    dbProjTotal = dbOper + dbSS + dbHMIS + dbLease + dbAdmin
 
    If blValidExpDate Then                      'LOCCS WITH START DATE(SD)
        If (Not blConstruction) Then
            dbARA = dbProjTotal / iTerm         'LOCCS+SD, NO ACQ/REH, Calculate ARA
        Else                                    'LOCCS+SD, With ACQ/REH
            dbAdmin = 0.05 * dbSSTotal              'Calculate ADMIN without ACQ/REH
            dbProjTotal = dbSSTotal + dbAdmin       'Project Total minus ACQ/REH
            vaSHPRenewals(i, 51) = 0.05 * dbSSTotal ':040806 Update ADMIN in Worksheet
            dbARA = dbProjTotal / iTerm             'Calculate ARA
       End If
    ElseIf blNotinLOCCS Then                    'NOT IN LOCCS
        dbProjTotal = dbCoCAward
        dbARA = dbProjTotal / iCoCTerm              ' Calculate ARA
    ElseIf (Not blNotinLOCCS) Then              'In LOCCS NO Start Date
        If iTerm < 1 Then                           'NO BLI Codes, Calculate ARA
            dbARA = dbCoCAward / iCoCTerm
        ElseIf (Not blConstruction) Then
            dbARA = dbProjTotal / iTerm             'HAS BLI + NO ACQ/REH, Calculate ARA
        End If
    End If
    vaSHPRenewals(i, 53) = dbProjTotal
    vaSHPRenewals(i, 54) = dbARA
End Sub
Sub B01_CreateCoCFiles()         'Create a separate file for each Continuum Name
'
'Activate with "Control-Shift T" key
'
    Dim i As Long
    Dim icount As Long
    Dim k As Long
    Dim wks As Worksheet
    Dim wkb As Workbook
    Dim Rng As Range
    Dim stLastRow As String
    Dim stCriteria As String
    Dim stCoCID As String
    Dim stCoCContName As String
    Dim stCoCFileName As String
    Dim t As Single
    Dim blB01Active As Boolean
    Dim blWkb2Open As Boolean
    Dim stPrintArea As String
 
    Call SetWkbObjects  ':061606 Allow "CTL-SHIFT-T" when B01 file not active
 
    Application.ScreenUpdating = True
    t = Timer
    '------------------------Initialize variables if Program has been "RESET"-------
    iButtonNmbr = 1
    If wkb2 Is Nothing Then Call SetWkbObjects
    If stCoCArray(0, 1) = "" Then Call B01_CoCArrayInit
    '-----':061606 Allow files to be created by Ctl-Shift-t if B01 Report open------
    For Each wkb In Workbooks
        If InStr(1, wkb.Name, "Grants Eligible for Renewal.SHP") > 0 Then
            Set wkb3 = wkb
            wkb3.Activate
            If ActiveSheet.AutoFilterMode = True Then Range("$A$1").CurrentRegion.AutoFilter
            blB01Active = True
        ElseIf InStr(1, wkb.Name, "A67R1.") > 0 Then
            Set wkb2 = wkb
            blWkb2Open = True
        End If
    Next wkb
    If Not blWkb2Open Then
        MsgBox ("There is no A67R1 file open - restart Bossnaps")
        ThisWorkbook.Activate
        Exit Sub
    End If
    If Not blB01Active Then
        MsgBox ("You must run button SHP Annual Renewal Verification Test first")
        ThisWorkbook.Activate
        Exit Sub
    End If
    '----Get the Office Continuum Count
    For i = 0 To 100
        If stCoCArray(0, i) = "" Then Exit For
        k = k + 1
    Next i
    icount = k
    UserForm1.Show vbModeless
 
    For i = 0 To 100
        MsgPublic = "Processing file " & i & " of " & k
        UserForm1.DisplayMsg
        If stCoCArray(0, i) = "" Then GoTo ExitSub:
        Workbooks(wkb3.Name).Activate
        Worksheets(2).Copy before:=Worksheets(1)
        Set Rng = Range("A1").CurrentRegion
        With Rng
            .Cells(1, 29).EntireColumn.Hidden = False
        End With
        Set wks = Worksheets(1)
        stCoCID = Mid(stCoCArray(0, i), 1, 4)   'Get rid of ":" in name
        UserForm1.ListBox1.AddItem stCoCArray(1, i)
        stCoCContName = stCoCArray(1, i)
        stCriteria = "<>" & stCoCID
        wks.Name = stCoCID
        Rows(2).Insert
        Range("AC2").Value = "Temp"
        stLastRow = Range("AC1").End(xlDown).Address
        With ActiveSheet
            .UsedRange
            Set Rng = Range("$AC$2:" & stLastRow)
            Rng.AutoFilter Field:=29, Criteria1:=stCriteria
            Rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .UsedRange
        End With
        Worksheets(1).Copy
        If ActiveSheet.AutoFilterMode = True Then Range("$A$1").CurrentRegion.AutoFilter
        '-----042707 Set Print Area to include the subtotals line------
        Set Rng = Range("$A$1").SpecialCells(xlCellTypeLastCell)
        stPrintArea = "$A$1:" & Rng.Address
        ActiveSheet.PageSetup.PrintArea = stPrintArea
        '----042707 Clear the Columb AB Total Line and put a title in cell-------
        Set Rng = Range("BA1").End(xlDown).Offset(2)
        Rng.Value = "Annual Renewals Total"
        Rng.HorizontalAlignment = xlRight
        Rng.Font.Bold = True
        Application.ScreenUpdating = True
        Range("B2").Select
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=B01_Replace(stCoCContName & ".xls")
        ActiveWorkbook.Close
        Workbooks(wkb3.Name).Worksheets(stCoCID).Delete
    Application.DisplayAlerts = True
    Next i
ExitSub:
    MsgPublic = icount & " Files Generated in BOSSNAPS folder" & Chr(13) & " Click 'X' to EXIT this menu"
    UserForm1.DisplayMsg
    Debug.Print "B01_CreateCoCFiles", , Format(Timer - t, "#0.#00"); "  A67 First Pass Filter & Copy results to new workbook"
End Sub
Sub B01_CoCArrayInit()      'FIX:090518-Select newest Annual CoC file (COC20nn) in DEPCON
    '----------------------------------------------------------------------------------
    ':061606-Major edits to be sure [CoCNames] Array is created each time button B01 is
    'run and to allow "CTL-Shift-t" to execute if B01 report is open but not active
    '----------------------------------------------------------------------------------
    'Public stCoC_IDName(1,100) As String      'Wkb3 field ??
 
    Dim wks As Worksheet
    Dim stCoCID As String
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim stCOCIDName As String
    Dim rgCopy As Range
    Dim rgDestination As Range
    Dim stCriteria As String
    Dim t As Single
 
    Application.ScreenUpdating = False
    t = Timer
 
    Call SetWkbObjects '-------DEBUG ONLY-----
    '----------------------------------------------------------------------------------
    'Delete all worksheets in the A67R1 workbook except "LOCCS_ALL"
    '----------------------------------------------------------------------------------
    Workbooks(wkb2.Name).Activate
    Application.DisplayAlerts = False
    For Each wks In Worksheets
        If InStr(1, wks.Name, "LOCCS_ALL") = 0 Then
            Debug.Print wks.Name
            Worksheets(wks.Name).Delete
        End If
    Next wks
    Application.DisplayAlerts = True
    Set wks = ActiveWorkbook.Sheets.Add
    Set rgCopy = Workbooks(wkb2.Name).Worksheets("LOCCS_ALL").Range("A1").CurrentRegion
    Set rgDestination = Workbooks(wkb2.Name).Worksheets(wks.Name).Range("A1")
    '-----------------------------------------------------------------------
    'Initialize the Advanced Filter Criteria to display only the most recent year of SHP grants
    '-----------------------------------------------------------------------
    With Worksheets(wks.Name).Activate
        rgDestination.Cells(1, 1).Value = "Program"
        rgDestination.Cells(2, 1).Value = "SHP"
        rgDestination.Cells(1, 2).Value = "Year"
        rgDestination.Cells(2, 2).Value = Fn_NewestCoCYear() ':090518- Update from 2004 to 2007
    End With
    With Worksheets("LOCCS_ALL").Activate
        rgCopy.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
            Workbooks(wkb2.Name).Sheets(wks.Name).Range("A1:B2"), Unique:=False
        '-----------------------------------------------------
        ' Hide all Wkb2 columns except for Grant#, CoCCode & COCName
        '-----------------------------------------------------
        rgCopy.Range(Cells(1, 1), Cells(1, 128)).EntireColumn.Hidden = True
        rgCopy.Cells(1, 1).EntireColumn.Hidden = False
        rgCopy.Cells(1, 29).EntireColumn.Hidden = False
        rgCopy.Cells(1, 34).EntireColumn.Hidden = False
        rgCopy.SpecialCells(xlCellTypeVisible).Copy (Workbooks(wkb2.Name).Worksheets(wks.Name).Range("A1"))
    End With
    Set rgDestination = Workbooks(wkb2.Name).Worksheets(wks.Name).Range("$A$1").CurrentRegion
    Workbooks(wkb2.Name).Worksheets(wks.Name).Activate
    With ActiveSheet
        rgDestination.Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
       '------------------------------------------------------------------------------
       'Enter here with only 3 fields, Grant#, CoCCode and CoCName, for all SHP grants
       '(about 270)listed in the A67 report year.  They are sorted by CoCCode. Extract a
       'CoCCode & CoCName for each CoCID and populate the stCoCArray(1,100)
       '------------------------------------------------------------------------------
        j = 1
        stCoCArray(0, 0) = .Cells(2, 2).Value   'COCID ARRAY element 0
        stCoCArray(1, 0) = .Cells(2, 3).Value   'COCNAME ARRAY element o
        For i = 3 To rgDestination.Rows.Count   'Start at range element #3
            If .Cells(i - 1, 2).Value <> .Cells(i, 2).Value Then    'Is next CoCName = Last?
                stCoCArray(0, j) = .Cells(i, 2).Value               'No-New CoCName to insert
                stCoCArray(1, j) = .Cells(i, 3).Value
                'Debug.Print stCoCArray(0, j), stCoCArray(1, j)  ':090515 Test
                j = j + 1       'Bump the stCoCArray( x,row pointer)
            End If
        Next i
        rgDestination.ClearContents
    End With
    '-----Delete the BOSSNAPS workbook.name "CoCName" if it exists ':061606---------------
    For k = 1 To Workbooks(wkb1.Name).Names.Count
        'Debug.Print k, Workbooks(wkb1.Name).Names(k).Name
        If Workbooks(wkb1.Name).Names(k).Name = "CoCNames" Then
            Workbooks(wkb1.Name).Names("CoCNames").Delete   ':061606 Delete existing name if it exist
            Exit For
        End If
    Next k
    Workbooks(wkb1.Name).Names.Add Name:="CoCNames", RefersTo:=stCoCArray    'Transfer stCoCArray to a Name
    '----------------------------------
    'Restore normal Wkb2 fields viewed
    '----------------------------------
    With Worksheets("LOCCS_ALL").Activate
        rgCopy.Range(Cells(1, 1), Cells(1, 38)).EntireColumn.Hidden = False
        rgCopy.Range(Cells(1, 39), Cells(1, 128)).EntireColumn.Hidden = True
        If ActiveSheet.AutoFilterMode = True Then Range("$A$1").CurrentRegion.AutoFilter
    End With
    Application.DisplayAlerts = False
    Worksheets(wks.Name).Delete
    Application.DisplayAlerts = True
    Debug.Print "   B01_CoCArrayInit", Format(Timer - t, "#0.#00"); "  "
End Sub
Sub B01_CoCContNames()
'--------------------------------------------------------------------------
'Assign a single Continuum ID/Name to every grant in a continuum. Note that
'input file will contain different CoC ID/Names for each Overview Report year.
'Choose the Continuum name assigned in the most recent Overview Report year
'--------------------------------------------------------------------------
    Dim stCoCID As String
    Dim stCOCIDName As String
    Dim stArrayContName As String
    Dim stArrayIndex As String
    Dim i As Long
    Dim j As Long
    Dim Rng As Range
    Dim t As Single
    Dim blArrayData As Boolean
 
 
    Application.ScreenUpdating = False
    t = Timer
    Call SetWkbObjects
    Workbooks(wkb3.Name).Worksheets("Sheet1").Activate
    '---------Sort the ARA records by CoC Code (MA00, MA01, etc to group CoC records----
    Set Rng = Range("A1").CurrentRegion
    With Rng
        .Sort Key1:=(Cells(1, 29)), Order1:=xlAscending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    End With
    'Examine the CoC ID/Name for each record in ARA table
    For i = 2 To Rng.Rows.Count
    stCoCID = Rng.Cells(i, 29).Value + ":"
        If Not blArrayData Then
            '----------This code will be executed only on first record--------------
            stArrayIndex = stCoCID
            For j = 0 To 100
                If stCoCID = stCoCArray(0, j) Then
                    stArrayContName = stCoCArray(1, j)
                    Rng.Cells(i, 34).Value = stArrayContName
                    Exit For
                End If
            Next j
            blArrayData = True
        ElseIf stCoCID = stArrayIndex Then
            Rng.Cells(i, 34).Value = stArrayContName
        ElseIf stCoCID <> stArrayIndex Then
            stArrayIndex = stCoCID
            For j = 0 To 100
                If stCoCID = stCoCArray(0, j) Then
                    stArrayContName = stCoCArray(1, j)
                    Rng.Cells(i, 34).Value = stArrayContName
                    Exit For
                End If
            Next j
        End If
    Next i
    Debug.Print "   B01_CoCContNames", Format(Timer - t, "#0.#00"); "  "
End Sub
Function B01_Replace(stInput As String)
    stInput = Replace(stInput, "/", "-")
    stInput = Replace(stInput, "&", "-")
    stInput = Replace(stInput, ":", "-")
    stInput = Replace(stInput, ";", "-")
    stInput = Replace(stInput, ",", "-")
    B01_Replace = stInput
End Function
Sub RenameFields()
    Dim i As Long
    Dim Rng As Range
    Dim t As Single
 
    t = Timer
    Set Rng = Range("A1:BB1")
    With Rng
        .Cells(1, 1).Value = "Grant Number"
        .Cells(1, 9).Value = "Grantee Name"
        .Cells(1, 10).Value = "Project Sponsor"
        .Cells(1, 11).Value = "Project Name"
        .Cells(1, 13).Value = "LOCCS Effective Date"
        .Cells(1, 14).Value = "Grant LOCCS Start Date"
        .Cells(1, 15).Value = "Grant Term in Months"
        .Cells(1, 16).Value = "LOCCS Expiration Date"
        .Cells(1, 34).Value = "Continuum Name"
   End With
    If iButtonNmbr = 1 Then
    With Rng
        .Cells(1, 15).Value = "Grant Term in Years"
        .Cells(1, 48).Value = "Operations"              'Rename "A_OPER"
        .Cells(1, 49).Value = "Supportive Services"     'Rename "A_SS"
        .Cells(1, 50).Value = "HMIS"                    'Rename "A_HMIS"
        .Cells(1, 51).Value = "Administration"          'Rename "A_ADMIN"
        .Cells(1, 52).Value = "Leasing"                 'Rename "A_LEASE"
        .Cells(1, 53).Value = "Total"                   'Total
        .Cells(1, 54).Value = "Annual Renewal Amount"   'Annual Renewal Amount
    End With
    End If
    Debug.Print "RenameFields", , Format(Timer - t, "#0.#00"); "  Update field names to make more readable  "
End Sub
Sub FormatBorders()
    '------------------------------------------------
    'Enter with the Worksheet to be formatted active
    '------------------------------------------------
 
    Dim t As Single
    Dim Rng As Range
 
 
    t = Timer
    Set Rng = Range("A1").CurrentRegion
    With Worksheets(ActiveSheet.Name).Range(Rng.Address).Borders(xlBottom)
        .LineStyle = xlContinuous
    End With
    With Worksheets(ActiveSheet.Name).Range(Rng.Address).Borders(xlLeft)
        .LineStyle = xlContinuous
    End With
    With Worksheets(ActiveSheet.Name).Range(Rng.Address).Borders(xlRight)
        .LineStyle = xlContinuous
    End With
    Debug.Print "FormatBorders", , Format(Timer - t, "#0.#00"); "  "
End Sub
Function LOCCS_RowsCnt(ifield As Integer, stCriteria As String)
'
'Count the # of 2006 grants to determine if the new year SHP/SPC grants have been entered
'
    Dim t As Single
    Dim Rng As Range
    Dim lRows As Long
    Dim lCount As Long
 
    'Call SetWkbObjects     'DEBUG ONLY
 
    Workbooks(wkb2.Name).Worksheets("LOCCS_ALL").Activate
    With ActiveSheet
        Set Rng = Range("A1").CurrentRegion
        lRows = Rng.Rows.Count
        Rng.AutoFilter Field:=ifield, Criteria1:=stCriteria
        lCount = Cells(lRows + 2, 1).Value
    End With
    LOCCS_RowsCnt = lCount
End Function
Sub SetEmptyFields()
    '--------------------------------------------------------------------------
    'If project not in LOCCS then set 3 fields to the following default values
    ' EFF_DATE = "Not in LOCCS"
    ' Start Date = "No Data
    ' Expiration Data = "No Data"
    '--------------------------------------------------------------------------
    'Exit Sub
 
    Dim i As Long
    Dim Rng As Range
    Dim t As Single
    Dim iField1 As Integer
    Dim iField2 As Integer
    Dim ifield3 As Integer
 
    t = Timer
    Select Case iButtonNmbr
        Case 17:    iField1 = 13: iField2 = 14: ifield3 = 16
        Case 19:    iField1 = 13: iField2 = 14: ifield3 = 16
        Case 21:    iField1 = 13: iField2 = 14: ifield3 = 16
        Case Else
            GoTo End1:
    End Select
    Set Rng = Range("A1").CurrentRegion
    For i = 2 To Rng.Rows.Count
        With Rng
            If Cells(i, iField1).Value = "" Then
                Cells(i, iField1).Value = "Not in LOCCS"
                Cells(i, iField1).Font.ColorIndex = 3
                Cells(i, iField2).Value = "No Data"
                Cells(i, iField2).Font.ColorIndex = 3
                Cells(i, ifield3).Value = "No Data"
                Cells(i, ifield3).Font.ColorIndex = 3
            End If
        End With
    Next i
End1:
    Debug.Print "SetEmptyFields", Format(Timer - t, "#0.#00"); "  iButtonNmber = "; iButtonNmbr
End Sub
Sub PinTest()
    Dim rgCopy As Range
    Dim rgDestination As Range
    Dim stLastRow As String
    Dim t As Single
 
    t = Timer
    If iButtonNmbr = 0 Then
        Call SetWkbObjects
        stWkb3Name = "PinTest.xls"
        If (wkb3 Is Nothing = False) Then Workbooks(wkb3.Name).Close
    End If
    '---------Create a new, empty workbook for this filter------------
    Set wkb3 = Workbooks.Add
    Application.DisplayAlerts = False
    wkb3.SaveAs Filename:=stWkb3Name
    Application.DisplayAlerts = True
    '------------Hide A67 Columns not needed for this button--------------------------
    wkb2.Activate
    If ActiveSheet.AutoFilterMode = True Then Range("$A$1").CurrentRegion.AutoFilter
    Set rgCopy = Workbooks(wkb2.Name).Worksheets("LOCCS_ALL").Range("A1").CurrentRegion
    With rgCopy
        .Range(Cells(1, 17), Cells(1, 128)).EntireColumn.Hidden = True
        .Range(Cells(1, 3), Cells(1, 5)).EntireColumn.Hidden = True
        .Range(Cells(1, 7), Cells(1, 8)).EntireColumn.Hidden = True
        .Cells(1, 12).EntireColumn.Hidden = True
        .Cells(1, 13).EntireColumn.Hidden = True
    End With
    '-----------Display only projects with PIN data---------------------
    Set rgCopy = Workbooks(wkb2.Name).Worksheets("LOCCS_ALL").Range("A1").CurrentRegion
    rgCopy.AutoFilter Field:=2, Criteria1:=">""""", Operator:=xlAnd
    'rgCopy.AutoFilter Field:=7, Criteria1:="2004"
    '-----------Copy only visible data to new workbook----------------------------------
    rgCopy.SpecialCells(xlCellTypeVisible).Copy (Workbooks(wkb3.Name).Worksheets("Sheet1").Range("A1"))
    Workbooks(wkb3.Name).Worksheets("Sheet1").Activate
    stLastRow = Range("A1").End(xlDown).Address
    Workbooks(wkb3.Name).Save
    Debug.Print "PINTest", , Format(Timer - t, "#0.#00"); "  rows = "; stLastRow
 
End Sub
Sub PinTestR1()
    'Public vrA67() As Variant
    'Public vrPIN(1000, 9) As Variant
 
    Dim rgCopy As Range
    Dim rgDestination As Range
    Dim rgPin As Range
    Dim stLastRow As String
    Dim iLastRow As Long
    Dim i As Long: Dim j As Long: Dim k As Long
 
    Dim t As Single
    Dim stThisPin As String
    Dim stLastPin As String
    Dim blNewLineOut As Boolean
 
    t = Timer
    '-------------This statement will allow subroutine to execute alone in debug mode-------
    If iButtonNmbr = 0 Then
        Call SetWkbObjects
        stWkb3Name = "PinTest.xls"
        If (wkb3 Is Nothing) Then
 
        Else
            Workbooks(wkb3.Name).Close
        End If
    End If
    '---------Create a new, empty workbook for this filter------------
    Set wkb3 = Workbooks.Add
    Application.DisplayAlerts = False
    wkb3.SaveAs Filename:=stWkb3Name
    Application.DisplayAlerts = True
    '----------Sort A67 so PINs are at top sorted by descending year--------------------
    Workbooks(wkb2.Name).Worksheets("LOCCS_ALL").Activate
    If ActiveSheet.AutoFilterMode = True Then Range("$A$1").CurrentRegion.AutoFilter
    Set rgCopy = Workbooks(wkb2.Name).Worksheets("LOCCS_ALL").Range("A1").CurrentRegion
    With rgCopy
        rgCopy.Sort Key1:=Range("$B1"), Order1:=xlAscending, Key2:=Range("$G1") _
            , Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
            False, Orientation:=xlTopToBottom
    End With
    '--------------Get the PIN Count/location of first blank cell---------------
    Range("B1").Select
    iLastRow = Range(ActiveCell, ActiveCell.End(xlDown)).Rows.Count
    Set rgCopy = Range("A1:P" & Trim(Str(iLastRow)))
    '---------------Copy the first 16 Columns to an array and size the Array-----------
    ReDim vrA67(1 To 16, 1 To iLastRow)
    vrA67 = rgCopy.Value
    '--------Create a new file by Pin#-------------------------------------------------
    Call PINHdr
    For i = 2 To iLastRow
        stThisPin = vrA67(i, 2)
        If stThisPin = stLastPin Then
            vrPIN(j, k) = vrA67(i, 1)
            vrPIN(j, k + 1) = vrA67(i, 15)
            vrPIN(j, k + 2) = vrA67(i, 14)
            vrPIN(j, k + 3) = vrA67(i, 16)
            k = k + 4
        Else
            j = j + 1
            k = 0
            vrPIN(j, k) = vrA67(i, 2)
            vrPIN(j, k + 1) = vrA67(i, 7)
            vrPIN(j, k + 2) = vrA67(i, 1)
            vrPIN(j, k + 3) = vrA67(i, 15)
            vrPIN(j, k + 4) = vrA67(i, 14)
            stLastPin = stThisPin
            k = k + 5
        End If
    'Debug.Print vrPin(j, 1), vrPin(j, 2), vrPin(j, 3), vrPin(j, 3)
    Next i
 
    Workbooks(wkb3.Name).Worksheets("Sheet1").Activate
    Set rgDestination = Range("A1:J" & Trim(Str(iLastRow)))
    rgDestination = vrPIN
    Workbooks(wkb3.Name).Save
    Debug.Print "PINTest", , Format(Timer - t, "#0.#00"); "  rows = "; stLastRow
End Sub
Sub PINHdr()
    'Public vrA67() As Variant
    'Public vrPIN(1000, 9) As Variant
 
    vrPIN(0, 0) = "PIN"
    vrPIN(0, 1) = "YEAR"
    vrPIN(0, 2) = "Grant1"
    vrPIN(0, 3) = "Term1"
    vrPIN(0, 4) = "Start Date1"
    vrPIN(0, 5) = "Grant2"
    vrPIN(0, 6) = "Term2"
    vrPIN(0, 7) = "Start Date2"
    vrPIN(0, 8) = "Exp Date2"
 
End Sub
Sub B17_CancelGrant()
'------------------------------------------------------------------------------------------------------
'Mark all grants "Cancelled" that are defined to LOCCS, more than 40 days old and have Authorized = 0
'Note that grants can be defined to LOCCS without budget line items for a short time.
'------------------------------------------------------------------------------------------------------
    'Exit Sub   '--------------Use only for debug---------------
 
    Dim rgDB3 As Range
    Dim rgMyRange As Range
    Dim i As Single
    Dim dbAuthorized As Double
    Dim dbBalance As Double
    Dim dtEffDate As Date
    Dim stStatus As String
    Dim t As Single
 
    t = Timer
    'Call SetWkbObjects  '-----------------USE ONLY FOR DEBUG--------------
    Application.ScreenUpdating = False
    Workbooks(wkb3.Name).Sheets("Sheet1").Activate
    Set rgMyRange = Range("$A1").CurrentRegion
    ActiveWorkbook.Names.Add Name:="Database", RefersToR1C1:=rgMyRange
    With Range("Database")
        If .Rows.Count = 1 Then
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count)
        Else
         Set rgDB3 = .Offset(1, 0).Resize(.Rows.Count - 1)
        End If
    End With
 
    For i = 1 To rgDB3.Rows.Count
        stStatus = rgDB3.Cells(i, 35).Value
        rgDB3.Cells(i, 18).Value = 1                'Set flage to default
        dbAuthorized = rgDB3.Cells(i, 20).Value
        dbBalance = rgDB3.Cells(i, 22).Value
        If dbAuthorized = 0 And dbBalance = 0 Then
            If IsDate(rgDB3.Cells(i, 13).Value) Then
                dtEffDate = rgDB3.Cells(i, 13).Value
                If DateAdd("d", 40, dtEffDate) < Now Then
                    rgDB3.Cells(i, 18).Value = 2                'Set flage to "Cancelled"
                End If
            End If
        ElseIf InStr(1, stStatus, ":Canc") > 0 Then 'Do Not Display Cancelled grants not defined to LOCCS
            rgDB3.Cells(i, 18) = 2
        End If
    Next i
    Debug.Print "B17_CancelGrant", Format((Timer - t), "#0.#00"); " Remove Unobligated Grants"
End Sub
Sub SetCoCIDName()
    Dim rgDB As Range, rgMyRange As Range
    Dim i As Long
    Dim t As Single
    Dim stCoCName As String
    Dim stProjNmbr As String
    Dim stSNAPS As String
 
    t = Timer
    Call SetWkbObjects
    If iCoCYear > 0 Then
        Debug.Print "CoCUpdate     -Original Overview Report already updated - EXIT"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Set Wkb4 = Workbooks.Open(Filename:=stCoCPath)
    Workbooks(Wkb4.Name).Worksheets("Sheet1").Activate
    Set rgDB3 = Range("$A1").CurrentRegion
    For i = 1 To rgDB3.Rows.Count
        stProjNmbr = rgDB3.Cells(i, 4)
        stSNAPS = Mid(stProjNmbr, 5, 1)
        If stSNAPS = "B" Or stSNAPS = "C" Then
            If rgDB3.Cells(i, 3).Value = "" Then               'Is the CoCID field empty
                rgDB3.Cells(i, 3).Value = Mid(stProjNmbr, 1, 2) + Mid(stProjNmbr, 7, 2) + ":"
            End If
        End If
    Next i
    Debug.Print "SetCoCIDName", , Format((Timer - t), "#0.#00"); "  Set COCID(MA00:) & COCContName(MA)):City of Boston)"
End Sub
Sub NameToArray()
'
'Need to run CoCArrayInit first then transfer to a Name
'Modify existing code so that array stCoCNames will be will be accomplished every time an A67 report is generate
'The CoC Names will be based on 2004 CoC names.
    'Names.Add Name:="CocArray", RefersTo:=stCoCArray    'Transfer stCoCArray to a Name
    vrCocNames = [cocarray]
End Sub
Sub CoCFiles()
'-------------------------------------------------------------------------------
'This is a stand alone routine that is activated with "Control-Shift C" key
'
'Create one Coc file for each CoC in "Database" worksheet of input file
'The active workbook will be used & must have a worksheet named "Database"
'Step#1-Create a Worksheet that has only 1 CoC name displayed
'Step#2-Copy the Worksheet to a new Workbook (Book xx)
'Step#3-Save Workbook "Book xx" using the CoC filename
'-------------------------------------------------------------------------------
    Dim i As Long
    Dim wks As Worksheet
    Dim Rng As Range
    Dim stLastRow As String
    Dim stCriteria As String
    Dim stCoCID As String
    Dim stCoCContName As String
    Dim stCoCFileName As String
    Dim t As Single
 
    t = Timer
    Application.ScreenUpdating = False
    '---------Reset autofilters if they are active----------------------------------
    If ActiveSheet.AutoFilterMode = True Then Range("$A$1").CurrentRegion.AutoFilter
    '---------Set the CoC names array from the Worksheet NAMES definitions----------
    vrCocNames = [CoCNames]
    For i = 1 To 100
        Application.DisplayAlerts = False
        '---If two worksheets exists, delete the copy-------
        Set wks = Worksheets("Database (2)")
        wks.Delete
        Application.DisplayAlerts = True
        '--Copy data to another worksheet in same workbook to save formatting and time---
        ActiveWorkbook.Sheets("Database").Copy before:=ActiveWorkbook.Sheets("Database")
        stCoCID = Mid(vrCocNames(1, i), 1, 4)   'Get rid of ":" in name
        stCoCContName = vrCocNames(2, i)
        stCriteria = "<>" & stCoCID '-----Example "<>MA00"----
        '----Insert a dummy header row after the real header row----
        Rows(2).Insert
        '----Define a dummy header field for the filtering----
        Range("C2").Value = "Temp"
        '---Get address of last row in column 29---------
        stLastRow = Range("AC1").End(xlDown).Address
        With ActiveSheet
            .UsedRange
            '----Define a range for only one column(29)without origninal header row----
            Set Rng = Range("$AC$2:" & stLastRow)
            '----Show only those rows that are NOT EQUAL to CoC
            Rng.AutoFilter Field:=29, Criteria1:=stCriteria
            '----Delete all visible cells(NOT EQUAL TO CoC)
            Rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .UsedRange
        End With
        Worksheets(1).Copy  '---Copy unique CoC data to new WORKBOOK(Book xx) & activate it---
        '----TURN OFF AUTOFILTERS to display all data------
        If ActiveSheet.AutoFilterMode = True Then Range("$A$1").CurrentRegion.AutoFilter
        Application.DisplayAlerts = False
        '---Save "Book xx" Workbook with CoC Name then close Workbook---------
        ActiveWorkbook.SaveAs Filename:=B01_Replace(stCoCContName & ".xls")
        ActiveWorkbook.Close
        '----???Delete the temporary worksheet created for one CoC file----
        Workbooks(wkb3.Name).Worksheets(stCoCID).Delete
        Application.DisplayAlerts = True
    Next i
    Debug.Print "CoCFiles", , Format(Timer - t, "#0.#00"); "  A67 First Pass Filter & Copy results to new workbook"
End Sub
Sub B20_GranteeCount()
'----------------------------------------------------------------------------
''----------------------------------------------------------------------------
    Dim i As Long, j As Long, k As Long
    Dim rgMyRange As Range
    Dim rgDB As Range
    Dim t As Single
    t = Timer
    Call SetWkbObjects
 
    Application.ScreenUpdating = False
    Workbooks(wkb3.Name).Sheets("Sheet1").Activate
    Set rgMyRange = Range("$A1").CurrentRegion
    ActiveWorkbook.Names.Add Name:="Database", RefersToR1C1:=rgMyRange
    With Range("Database")
        If .Rows.Count = 1 Then
         Set rgDB = .Offset(1, 0).Resize(.Rows.Count)
        Else
         Set rgDB = .Offset(1, 0).Resize(.Rows.Count - 1)
        End If
    End With
    '----Get the Grants Count and Grants Sum from the Subtotals row
 
 
 
    '----Advanced Filter for the Grantee Count------------------------
 
 
    GoTo EndCount:
    '-------------------------------------------
    'Sort the database by the "Grantee_TIDield
    '-------------------------------------------
    Range("A1").CurrentRegion.Select
    Selection.Sort Key1:=Range("L1"), Order1:=xlAscending, Key2:=Range("L1") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom
        '-----------------------------------------------------------------
        'THIS GRANT IS IN LOCCS - MARK RECORD AS "KEEPER" IF THE GRANTEE
        'IS NOT THE SAME AS IN PREVIOUS RECORD
        '-----------------------------------------------------------------
 
    For i = 1 To rgDB.Rows.Count
                 'Set flag to "delete" by default
        'If IsEmpty(rgDB.Cells(i, 12)) Then
            'rgDB.Cells(1, 18).Value = -1
    '---042707 fix for false tax ID......
       If InStr(1, (rgDB.Cells(i, 12).Value), "Not") > 0 Then
            rgDB.Cells(i, 18).Value = -1
        ElseIf (rgDB.Cells(i, 12).Value) <> (rgDB.Cells(i + 1, 12).Value) Then
            rgDB.Cells(i, 18).Value = 2
        Else
            rgDB.Cells(i, 18).Value = -1
        End If
    Next i
EndCount:
    Debug.Print "GrantCount", , Format(Timer - t, "#0.#00")
End Sub
Sub B21_LoseFunding()
    Dim i As Long, j As Long, k As Long
    Dim rgMyRange As Range
    Dim rgDB As Range
    Dim iRptYear As Integer
    Dim iGrantYear As Integer
    Dim blGrantCancel As Boolean
    Dim blNotinLOCCS As Boolean
    Dim stCoCComponent As String
    Dim t As Single
    Dim stStatus As String
    t = Timer
    Call SetWkbObjects
 
    Application.ScreenUpdating = False
    Workbooks(wkb3.Name).Sheets("Sheet1").Activate
    Set rgMyRange = Range("$A1").CurrentRegion
    ActiveWorkbook.Names.Add Name:="Database", RefersToR1C1:=rgMyRange
    With Range("Database")
        If .Rows.Count = 1 Then
         Set rgDB = .Offset(1, 0).Resize(.Rows.Count)
        Else
         Set rgDB = .Offset(1, 0).Resize(.Rows.Count - 1)
        End If
    End With
    '-------------------------------------------
    'Sort the database by the "Grantee_TIDield
    '-------------------------------------------
    Range("A1").CurrentRegion.Select
    Selection.Sort Key1:=Range("L1"), Order1:=xlAscending, Key2:=Range("L1") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom
 
    For i = 1 To rgDB.Rows.Count
        iRptYear = Year(rgDB.Cells(1, 23))  ' "LOCCS_RptDate" field
        If IsNumeric(rgDB.Cells(i, 7).Value) Then iGrantYear = rgDB.Cells(i, 7).Value
        If (InStr(1, rgDB.Cells(i, 35).Value, ":Can") > 0) Then
            blGrantCancel = True
        Else
            blGrantCancel = False
        End If
        If InStr(1, rgDB.Cells(i, 12).Value, "Not in LOCCS") > 0 Then blNotinLOCCS = True
        rgDB.Cells(i, 18).Value = -1
        If blNotinLOCCS Then
            If (Not blGrantCancel) And (iRptYear - iGrantYear = 2) Then
                rgDB.Cells(i, 18).Value = 4 'Grant will be deobligated this september
            End If
        End If
    Next i
    Debug.Print "B21_LoseFunding", , Format(Timer - t, "#0.#00")
End Sub
Sub A67SetCoCID(stOffice As String)
 
 
    Dim wkb As Workbook
    Dim wkb2 As Workbook
    Dim Rng As Range
    Dim t As Single
    Dim i As Long
    Dim iYear As Integer
    Dim Project As String
    Dim State As String
    Dim dtEffDate As Date
    Dim stPgm As String
    Dim C1234 As String
    Dim C78 As String
    If stOffice <> "Houston" Then
    Debug.Print "      A67SetCoCID()", , "CPD Office " & stOffice & " Does not need filtering"
        Exit Sub
    End If
    t = Timer
   For Each wkb In Workbooks
        If InStr(1, wkb.Name, "A67R1.") > 0 Then Set wkb2 = wkb
    Next wkb
    If wkb2 Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    wkb2.Worksheets("LOCCS_ALL").Activate
    Range("A1").CurrentRegion.Name = "A67data"
    Set Rng = Range("A67data")
 
    For i = 2 To Rng.Rows.Count
        '----------------------------------------------------
        If IsDate(Rng.Cells(i, 13).Value) Then
            dtEffDate = Rng.Cells(i, 13).Value
        Else
            dtEffDate = #1/1/2000#
        End If
        If Not IsNumeric(Rng.Cells(i, 7)) Then
            iYear = 1900
        Else
            iYear = Rng.Cells(i, 7).Value
        End If
        State = Rng.Cells(i, 8).Value
        stPgm = Mid(Rng.Cells(i, 5).Value, 1, 4)
        C1234 = Mid(Rng.Cells(i, 1).Value, 1, 4)
        C78 = Mid(Rng.Cells(i, 1).Value, 7, 2)
 
        If iYear < 2003 Then        ':051407 Fix for Houston
                Rng.Cells(i, 29).Value = "OLD"
        ElseIf (dtEffDate < #1/2/1999#) Then
                Rng.Cells(i, 29).Value = State + "OLD"
        ElseIf stPgm = "SHP" Or stPgm = "SPC" Or stPgm = "SRO" Then
                Rng.Cells(i, 29).Value = C1234 & "-" & C78
        ElseIf stPgm = "HPAC" Then
                Rng.Cells(i, 29).Value = State + "HP"
        ElseIf stPgm = "YB" Then
                Rng.Cells(i, 29).Value = State + "YB"
        End If
    Next i
    Debug.Print "      A67SetCoCID", Format((Timer - t), "#0.#00"), "Create the COC ID MA01-00, MA06-05, YBxx, HOPWAxx"
End Sub
Sub A67SetCriteria(stOffice As String)
    Dim wkb As Workbook
    Dim wkb1 As Workbook
    Dim Rng As Range
    Dim t As Single
    Dim i As Long
 
    t = Timer
    'If stOffice <> "Houston" Then
    'Debug.Print "      A67SetCriteria", , "CPD Office" & stOffice & " does not need filtering"
        'Exit Sub
    'End If
 
    For Each wkb In Workbooks
        If InStr(1, wkb.Name, "BOSSNAPS") = 1 Then Set wkb1 = wkb
    Next wkb
    If wkb1 Is Nothing Then Exit Sub
 
    Application.ScreenUpdating = False
    Workbooks(wkb1.Name).Worksheets("Criteria").Activate
    Workbooks(wkb1.Name).Worksheets("Criteria").Range("AI1:AI40").Select
    Select Case stOffice
        Case "Houston"
            With Selection
                .Cells(1, 1) = "Temp"
                .Cells(2, 1) = "*OLD"
                .Cells(3, 1) = "NM*"
                .Cells(4, 1) = "*YB"
                .Cells(5, 1) = "TX??-00"
                .Cells(6, 1) = "TX??-01"
                .Cells(7, 1) = "TX??-03"
                .Cells(8, 1) = "TX??-04"
                .Cells(9, 1) = "TX??-05"
                .Cells(10, 1) = "TX??-06"
                .Cells(11, 1) = "TX??-07"
                .Cells(12, 1) = "TX??-09"
                .Cells(13, 1) = "TX??-10"
                .Cells(14, 1) = "TX??-11"
                .Cells(15, 1) = "TX??-13"
                .Cells(16, 1) = "TX??-14"
                .Cells(17, 1) = "TX??-15"
                .Cells(18, 1) = "TX??-17"
                .Cells(19, 1) = "TX??-18"
                .Cells(20, 1) = "TX??-19"
                .Cells(21, 1) = "TX??-20"
                .Cells(22, 1) = "TX??-21"
                .Cells(23, 1) = "TX??-22"
                .Cells(24, 1) = "TX??-40"
                .Cells(25, 1) = "TX??-60"
            End With
        Case "Seattle"
            With Selection
                .Cells(1, 1) = "Temp"
                .Cells(2, 1) = "OR*"
                .Cells(3, 1) = "AK*"
                .Cells(4, 1) = "ID*"
            End With
        Case Else
    End Select
    Debug.Print "      A67SetCriteria()", Format((Timer - t), "#0.#00"), "Set the Advanced Filter Criteria"
End Sub
Function Fn_NewestCoCYear() As String   'FIX:090518 - Choose newest CoC Year for CoC Names
    Dim fs As Variant
    Dim fs1 As Variant
    Dim f As Variant
    Dim f1 As Variant
    Dim fc As Variant
    Dim stFileSearch As String
    Call SetDepconDir   '----DEBUG ONLY----
    '-----------------------------------------------------
    'Find the latest version of the Annual Overview report
    'Files are sorted so last one will be newest
    '-----------------------------------------------------
    stFileSearch = "CoC_*.20*.xls"
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(stDEPCONDir)
    Set fc = f.Files    'Create a list object of all files in DEPCON Directory
    For Each f1 In fc                           'Test each file in list
        If (f1.Name Like stFileSearch) Then
            Fn_NewestCoCYear = Mid(f1.Name, InStr(f1.Name, ".20") + 1, 4)
        End If
    Next
 
End Function
 
Upvote 0
In this,

Code:
Set wkb = Workbooks(stCoCPath)

stCoCPath must NOT include the path.

In this,

Code:
If wkb Is Nothing Then
    Workbooks.Open stCoCPath
End If

stCoCPath MUST include the full path and filename unless the workbook is in the current directory.
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,256
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top