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
