Portfolio Summary Macro

Sub SummarizePortfolios()
Dim wsIn As Worksheet, wsOut As Worksheet, ws As Worksheet
Dim idx As Object, secList As Object
Dim lastRow As Long, r As Long, n As Long, i As Long, j As Long, t As Long
Dim a As String, sec As String, nm As String, key As String, lastName As String
Dim rawA As String
Dim curSecNo As Long, outRow As Long
Dim cV As Double, dV As Double, totC As Double, totV As Double
Dim secs() As String, nms() As String
Dim secNo() As Long, cnt() As Long, ord() As Long
Dim cst() As Double, vl() As Double

Set wsIn = ActiveSheet
If wsIn.Name = "Summary" Then
MsgBox "Click your data sheet first, then run the macro.", vbExclamation
Exit Sub
End If

wsIn.UsedRange.UnMerge
lastRow = wsIn.UsedRange.Rows.Count + wsIn.UsedRange.Row

ReDim secs(1 To lastRow): ReDim nms(1 To lastRow)
ReDim secNo(1 To lastRow): ReDim cnt(1 To lastRow): ReDim ord(1 To lastRow)
ReDim cst(1 To lastRow): ReDim vl(1 To lastRow)

Set idx = CreateObject("Scripting.Dictionary")
Set secList = CreateObject("Scripting.Dictionary")

For r = 1 To lastRow
rawA = Trim(CStr(wsIn.Cells(r, 1).Value))

If rawA <> "" And Right(rawA, 2) = "%)" Then
sec = rawA
If Not secList.Exists(sec) Then secList.Add sec, secList.Count + 1
curSecNo = secList(sec)
Else
If rawA <> "" Then lastName = rawA
a = rawA
If a = "" Then a = lastName

If a <> "" Then
If IsAmount(wsIn.Cells(r, 3).Value) Or IsAmount(wsIn.Cells(r, 4).Value) Then
nm = BaseName(a)
key = LCase(sec & "|" & nm)
If Not idx.Exists(key) Then
n = n + 1
idx.Add key, n
secs(n) = sec: nms(n) = nm: secNo(n) = curSecNo
End If
i = idx(key)
cV = ToNum(wsIn.Cells(r, 3).Value)
dV = ToNum(wsIn.Cells(r, 4).Value)
cst(i) = cst(i) + cV
vl(i) = vl(i) + dV
cnt(i) = cnt(i) + 1
End If
End If
End If
Next r

If n = 0 Then
MsgBox "No data found. Check that Cost is in column C and Fair Value in column D.", vbExclamation
Exit Sub
End If

For i = 1 To n: ord(i) = i: Next i
For i = 1 To n - 1
For j = i + 1 To n
If secNo(ord(j)) < secNo(ord(i)) Or _
(secNo(ord(j)) = secNo(ord(i)) And _
StrComp(nms(ord(j)), nms(ord(i)), vbTextCompare) < 0) Then
t = ord(i): ord(i) = ord(j): ord(j) = t
End If
Next j
Next i

For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Summary" Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
Exit For
End If
Next ws

Set wsOut = ActiveWorkbook.Worksheets.Add(After:=wsIn)
wsOut.Name = "Summary"
wsOut.Range("A1:E1").Value = Array("Section", "Portfolio", "Total Cost", "Total Fair Value", "Lines Combined")
wsOut.Range("A1:E1").Font.Bold = True

outRow = 2
For i = 1 To n
t = ord(i)
wsOut.Cells(outRow, 1).Value = secs(t)
wsOut.Cells(outRow, 2).Value = nms(t)
wsOut.Cells(outRow, 3).Value = cst(t)
wsOut.Cells(outRow, 4).Value = vl(t)
wsOut.Cells(outRow, 5).Value = cnt(t)
totC = totC + cst(t): totV = totV + vl(t)
outRow = outRow + 1
Next i

wsOut.Cells(outRow, 2).Value = "GRAND TOTAL"
wsOut.Cells(outRow, 3).Value = totC
wsOut.Cells(outRow, 4).Value = totV
wsOut.Range(wsOut.Cells(outRow, 1), wsOut.Cells(outRow, 5)).Font.Bold = True
wsOut.Range("C2:D" & outRow).NumberFormat = "#,##0;(#,##0)"
wsOut.Columns("A:E").AutoFit
MsgBox "Done: " & n & " portfolios summarized.", vbInformation
End Sub

Private Function BaseName(ByVal s As String) As String
Dim m As Variant, p As Long, pos As Long
s = Trim(s)
pos = Len(s) + 1
For Each m In Array(", Series ", " Series ", " - ", " Bridge Loan", _
", Common", " Common", ", Ordinary", " Ordinary", _
", Preferred", " Preferred")
p = InStr(1, s, m, vbTextCompare)
If p > 0 Then
Select Case Trim(Replace(m, ",", ""))
Case "Common", "Ordinary", "Preferred"
If p + Len(m) - 1 <> Len(s) Then p = 0
End Select
End If
If p > 0 And p < pos Then pos = p
Next m
BaseName = Trim(Replace(Left(s, pos - 1), " ", " "))
Do While Right(BaseName, 1) = "," Or Right(BaseName, 1) = " "
BaseName = Left(BaseName, Len(BaseName) - 1)
Loop
End Function

Private Function IsAmount(v As Variant) As Boolean
Dim s As String
s = Replace(Replace(Replace(Trim(CStr(v)), ",", ""), "$", ""), " ", "")
If Left(s, 1) = "(" And Right(s, 1) = ")" Then s = Mid(s, 2, Len(s) - 2)
IsAmount = (s <> "" And IsNumeric(s))
End Function

Private Function ToNum(v As Variant) As Double
Dim s As String, neg As Boolean
s = Replace(Replace(Replace(Trim(CStr(v)), ",", ""), "$", ""), " ", "")
If Left(s, 1) = "(" And Right(s, 1) = ")" Then
neg = True
s = Mid(s, 2, Len(s) - 2)
End If
If s <> "" And IsNumeric(s) Then ToNum = CDbl(s)
If neg Then ToNum = -ToNum
End Function