Option Explicit Sub AkCapDataBuilder() ' ModDesc 01/09/17 DataPrep-Create Portfolio summary ' 03/02/17 Move TranBase from separate workbook to CapData work book ' 06/25/17 Scrap CapData Ptr for Portfolio Evaluation Group(PEG) ' 07/23/17 Use hard AppCtrl.xlsm name rather than ActiveWorkbook variable ' 07/24/17 Use hard coded names for application workbooks ' 12/23/17 Scrap Beta ' 01/07/18 Add worksheet qualification to cell references ' 01/13/18 Add Comp Map file numbers to AllSmmy ' 02/12/18 Eliminate PEG segregation of Prospects and Holdings ' 03/18/18 Code AllSmmy as *Holding, *PrevHeld, *Prospect ' 06/04/18 Name change to correct sequence of execution ' 07/28/18 EkSummary rebuild, CapData,CapHist replaced by FriCap,FriHist ' 09/03/18 Scrap FriHist sort, always in sym,FCD sequence ' 01/01/19 Portfolio macros must select portfolio client ' 01/06/19 Cash transactions coded with event *Cash ' 03/29/19 Adopt MarketXLS, FriCap to CapData, FdFriCapBuilder to EfCapDataBuilder ' 04/16/20 Add PEG Audit from EdReset ' 05/16/20 EfCapDataBuilder becomes DkCapDataBuilder DataPrep Create Portfolio summary ' 06/18/20 Positive entity test and *PEI preparation ' 06/21/20 Reformat Balance worksheet, include entity ' 07/04/20 Use MarketXLS ETFNetAssets to compute *ETF shares outstanding ' 07/06/20 Srap posting of CapData average cost basis ' 07/06/20 Scrap 3 year dividend and average PPS ' 07/21/20 Adopt ExecCtrl Client consolidated attribute statement ' 07/24/20 Post default stock symbol to ExecCtrl.ClientOpt Portfolio Optn ' 01/21/21 Adopt purchase Block coding ' 07/19/21 Scrap CapData.fLSG generation, EdHoldings.Ed1Keys generates and discards ' 07/19/21 Scrap CapData.fHPP generation, EdHoldings.Ed3Pages generates and discards ' 07/30/21 Reformat CapData sheet, drop dead fields and reorder columns ' 10/22/21 DkCapDataBuilder becomes DfCapDataBuilder provide room for DhPEGlinks ' 10/28/21 Chg program name, web nav, page updates and other changes ' 11/07/21 Scrap default stock symbol ' 12/04/21 Adopt No partner format and no partner distribution TranBase ' 02/11/22 Application.Screen, Calc, Events set via ExecCtrl.ExecByPLC ' 02/11/22 Replace sheet.Select Sort with Range specific method Dim er As Integer Dim ePLr As Integer Dim ePr1 As Integer Dim aCCN As String Dim aPth As String Dim aCPE As Date Dim aHCV As Currency Dim fr As Integer Dim frLE As Integer Dim fRng As String Dim fCap As Single Dim fENA As String ' ETF net assets from MarketXLS Dim tr As Integer Dim tTDt As Date Dim tEvt As String Dim tShs As Integer Dim tAmt As Currency Dim tPSS As Single Dim pSaB As String Dim pSym As String Dim pShs As Integer Dim pCst As Currency Dim pCBA As Double Dim pTDR As Currency Dim sSym As String Dim s1PD As Date Dim sShs As Integer Dim sCst As Currency Dim sCBA As Double Dim sTDR As Currency Dim sCsh As Currency Dim sIAF As Single Dim br As Integer Dim brLE As Integer Dim bPEG() As String Dim bNUA() As Integer ' Set operating environment--------------------------------- er = 2 While Sheets("ExecCtrl").Cells(er, 2) > "" If Sheets("ExecCtrl").Cells(er, 2) = "ExecByPLC" Then ePLr = er If Sheets("ExecCtrl").Cells(er, 3) = "*Yes" And _ Sheets("ExecCtrl").Cells(er, 4) = "AkCapDataBuilder" And _ Sheets("ExecCtrl").Cells(er, 5) = "*Launch" Then Else Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False End If End If If Sheets("ExecCtrl").Cells(er, 2) = "Parm1" Then _ ePr1 = er If Sheets("ExecCtrl").Cells(er, 2) = "CurClient" Then _ aCCN = Sheets("ExecCtrl").Cells(er, 3) If Sheets("ExecCtrl").Cells(er, 2) = "Client" And _ Sheets("ExecCtrl").Cells(er, 3) = aCCN And _ Sheets("ExecCtrl").Cells(er, 4) = "Port" Then aCPE = Sheets("ExecCtrl").Cells(er, 5) aPth = Sheets("ExecCtrl").Cells(er, 6) End If er = er + 1 Wend If aPth = "" Then Stop ' Reset to *Prospect ---------------------------------------------------------------- Workbooks.Open Filename:=aPth & "ClientData.xlsx" fr = 2 While Sheets("CapData").Cells(fr, 1) > "" If Sheets("CapData").Cells(fr, 2) = "*ETF" Or _ Sheets("CapData").Cells(fr, 2) = "*PEI" Or _ Sheets("CapData").Cells(fr, 2) = "*Stock" Then _ Sheets("CapData").Cells(fr, 12) = "*Prospect" fr = fr + 1 Wend frLE = fr - 1 ActiveWorkbook.Worksheets("CapData").Sort.SortFields.Clear fRng = "A2:A" & CStr(frLE) ActiveWorkbook.Worksheets("CapData").Sort.SortFields.Add2 Key:=Range(fRng) fRng = "A1:Y" & CStr(frLE) With ActiveWorkbook.Worksheets("CapData").Sort .SetRange Range(fRng) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Call S1TBCleaner ' Summarize purchase blocks to CapData ----------------------------------------------- tr = 2 pSaB = Sheets("TranBase").Cells(2, 1) pSym = Left(pSaB, Len(pSaB) - 3) sSym = pSym Do ' Accumulate purchase block shares, cost, CBA and div While Sheets("TranBase").Cells(tr, 1) = pSaB tTDt = Sheets("TranBase").Cells(tr, 2) tEvt = Sheets("TranBase").Cells(tr, 3) tShs = Sheets("TranBase").Cells(tr, 5) tAmt = Sheets("TranBase").Cells(tr, 6) Select Case tEvt Case "1-Purchase" If s1PD = 0 Then s1PD = tTDt pShs = tShs pCst = tAmt pCBA = pCBA + (tAmt * (aCPE + 1 - tTDt)) Case "2-Split" pShs = pShs + tShs pCBA = pCBA + (tAmt * (aCPE + 1 - tTDt)) Case "4-Sale" tPSS = tShs / pShs pShs = pShs - tShs pCBA = pCBA - ((pCst * tPSS) * (aCPE + 1 - tTDt)) pCst = pCst - (pCst * tPSS) Case "8-Cash" If s1PD = 0 Then s1PD = tTDt sCsh = sCsh + tAmt Case Else If Left(tEvt, 2) = "3-" Then _ pTDR = pTDR + tAmt End Select tr = tr + 1 Wend ' Roll purchase block to Sym summary sShs = sShs + pShs sCst = sCst + pCst sCBA = sCBA + pCBA sTDR = sTDR + pTDR pShs = 0 pCst = 0 pCBA = 0 pTDR = 0 pSaB = Sheets("TranBase").Cells(tr, 1) pSym = "" If pSaB > "" Then _ pSym = Left(pSaB, Len(pSaB) - 3) ' Post Sym summary to CapData If pSym <> sSym Then fr = 1 Do fr = fr + 1 If Sheets("CapData").Cells(fr, 1) = sSym Then Exit Do Loop ' Post open position results If sShs = 0 And sCst = 0 And sCsh = 0 Then Sheets("CapData").Cells(fr, 12) = "*PrevHeld" Else If Sheets("CapData").Cells(fr, 2) = "*Cash" Then Sheets("CapData").Cells(fr, 12) = "*Holding" Sheets("CapData").Cells(fr, 22) = s1PD Sheets("CapData").Cells(fr, 25) = sCsh Else Sheets("CapData").Cells(fr, 12) = "*Holding" Sheets("CapData").Cells(fr, 21) = sShs Sheets("CapData").Cells(fr, 22) = s1PD Sheets("CapData").Cells(fr, 23) = sCst Sheets("CapData").Cells(fr, 25) = Sheets("CapData").Cells(fr, 11) * sShs aHCV = aHCV + Sheets("CapData").Cells(fr, 25) Sheets("CapData").Cells(fr, 24) = Sheets("CapData").Cells(fr, 25) - sCst Sheets("CapData").Cells(fr, 13) = 0 Sheets("CapData").Cells(fr, 14) = 0 Sheets("CapData").Cells(fr, 15) = 0 sIAF = (aCPE - s1PD) / 365.25 If sIAF > 0 Then Sheets("CapData").Cells(fr, 13) = Round(sTDR / sIAF / 12, 2) sCBA = sCBA / (aCPE + 1 - s1PD) Sheets("CapData").Cells(fr, 14) = sTDR / sIAF / sCBA Sheets("CapData").Cells(fr, 15) = (Sheets("CapData").Cells(fr, 24) + sTDR) / sIAF / sCBA End If End If End If sSym = pSym s1PD = 0 sShs = 0 sCst = 0 sCBA = 0 sTDR = 0 sCsh = 0 End If Loop Until Sheets("TranBase").Cells(tr, 1) = "" ' Set *Holding %ofPortfolio and capitalization ----------------------------------- fr = 2 While Sheets("CapData").Cells(fr, 1) > "" Select Case Sheets("CapData").Cells(fr, 2) Case "*Heading", "*Format" Case "*Idx", "*PEI" Sheets("CapData").Cells(fr, 18) = "" ' Capitalization Case "*Cash" Sheets("CapData").Cells(fr, 18) = "" Case "*CD" Sheets("CapData").Cells(fr, 18) = "" Case "*Bond" Sheets("CapData").Cells(fr, 18) = "" Case "*ETF" Workbooks("AppCtrl.xlsm").Sheets("ExecCtrl").Cells(ePr1, 3) = _ "=ETFNetAssets(" & Chr(34) & Sheets("CapData").Cells(fr, 1) & Chr(34) & ")" fENA = Workbooks("AppCtrl.xlsm").Sheets("ExecCtrl").Cells(ePr1, 3).Value If IsNumeric(fENA) Then _ Sheets("CapData").Cells(fr, 7) = CDec(fENA) / Sheets("CapData").Cells(fr, 11) Case "*Fund" Sheets("CapData").Cells(fr, 18) = "" Case "*Stock" Workbooks("AppCtrl.xlsm").Sheets("ExecCtrl").Cells(ePr1, 3) = _ "=Shares_Outstanding(" & Chr(34) & Sheets("CapData").Cells(fr, 1) & Chr(34) & ")" If IsNumeric(Workbooks("AppCtrl.xlsm").Sheets("ExecCtrl").Cells(ePr1, 3).Value) Then _ Sheets("CapData").Cells(fr, 7) = _ Workbooks("AppCtrl.xlsm").Sheets("ExecCtrl").Cells(ePr1, 3).Value Case Else Stop End Select Workbooks("ClientData.xlsx").Activate If Sheets("CapData").Cells(fr, 2) = "*ETF" Or _ Sheets("CapData").Cells(fr, 2) = "*Stock" Then fCap = Sheets("CapData").Cells(fr, 7) * Sheets("CapData").Cells(fr, 11) Select Case fCap Case Is > 10000000000# Sheets("CapData").Cells(fr, 18) = "LargeCap" Case Is > 2000000000# Sheets("CapData").Cells(fr, 18) = "MidCap" Case Else Sheets("CapData").Cells(fr, 18) = "SmallCap" End Select End If fr = fr + 1 Wend ' Audit PEG assignments ---------------------------------------------------- br = 2 While Sheets("Balance").Cells(br, 1) > "" br = br + 1 Wend brLE = br ReDim bPEG(2 To brLE) As String ReDim bNUA(2 To brLE) As Integer For br = 2 To brLE bPEG(br) = Sheets("Balance").Cells(br, 1) bNUA(br) = Sheets("Balance").Cells(br, 3) Next fr = 2 While Sheets("CapData").Cells(fr, 1) > "" If Sheets("CapData").Cells(fr, 2) = "*Cash" Or _ Sheets("CapData").Cells(fr, 2) = "*ETF" Or _ Sheets("CapData").Cells(fr, 2) = "*Stock" Then If Sheets("CapData").Cells(fr, 12) = "*Holding" Then For br = 2 To brLE If Sheets("CapData").Cells(fr, 3) = bPEG(br) Then bNUA(br) = bNUA(br) - 1 Next End If End If fr = fr + 1 Wend For br = 2 To brLE If bNUA(br) < 0 Then Stop Next ' Close open workbooks------------------------------------------------------ Application.DisplayAlerts = False Workbooks("ClientData.xlsx").Activate Workbooks("ClientData.xlsx").Save Workbooks("ClientData.xlsx").Close Application.DisplayAlerts = True ' Close and post completion er = ePLr Workbooks("AppCtrl.xlsm").Activate If Sheets("ExecCtrl").Cells(er, 3) = "*Yes" And _ Sheets("ExecCtrl").Cells(er, 4) = "AkCapDataBuilder" Then Sheets("ExecCtrl").Cells(er, 5) = "*Compl" Else Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End If End Sub