Option Explicit
Public titlerows As Integer
Sub PrincipalComponents()
titlerows = 1

Dim quitit As Variant
'
' PrincipalComponents Macro
' Macro recorded 5/15/00 by Sara Brumbaugh
'
' Keyboard Shortcut: Ctrl+f
'
Dim numRows As Long, numCols As Long, numXRows As Long
Dim raw() As Double, x() As Double, Xcoltot() As Double
Dim vcov() As Double, xMean() As Double
Dim denompc1 As Double, denompc2 As Double, denom() As Double, corr() As Double
Dim a() As Double, b() As Double, adiag() As Double
Dim eigentot As Double, eigenind() As Double, eigencum() As Double
Dim scores() As Double
Dim titlrows As Integer
Dim titles() As String
Dim sceName As String
Dim whatinit As Integer
Dim rawRange As Variant
Dim contigyn As Integer
Dim tempx As Variant
Dim kountr As Long, goon As Integer, xblock As Integer
Dim outFrame As Range
Dim stddev() As Double, xnorm() As Double, sumxsq() As Double
Dim variance() As Double
Dim saraerror() As String
Dim bombed As Integer

On Error GoTo exitLine

sceName = InputBox(prompt:= _
  "Please name your scenario (<= 4 letters: ALL, MKTG, etc.)", _
  Title:="Principal Components")
If sceName = "" Then
  quitit = MsgBox("No scenario name, continue?", 4, "Continue?")
  If quitit = 7 Then GoTo finexit
End If
contigyn = MsgBox("Is your X-range contiguous within the worksheet?", _
           4, "Principal Components for " & sceName)
xstart:
If contigyn = 6 Then
   Set rawRange = Application.InputBox(prompt:= _
   "Please drag to outline X range, including column titles", _
   Title:="Principal Components for " & sceName, Type:=8)

    titlrows = 0
    Dim i As Integer
    For i = 1 To 5
        whatinit = VarType(rawRange(i, 1))
        If whatinit = 8 Then titlrows = titlrows + 1 Else _
        titlrows = titlrows
    Next i
    If titlrows = 0 Then GoTo exitLine
    
    rawRange.Worksheet.Activate
    rawRange.Select
    With Selection
      numRows = Selection.Rows.Count - titlrows
      numCols = Selection.Columns.Count
      Call Filler(numRows, numCols, raw, titlrows, titles)
    End With

ElseIf contigyn = 7 Then _
  goon = 6
  kountr = 0
  numCols = 0
  xblock = 0
  
  Do While goon = 6
    xblock = xblock + 1
xnocontigline:
    Set rawRange = Application.InputBox(prompt:= _
    "Please drag to outline X column(s), including title(s) " _
    & VBA.Chr(13) & _
    "OK to drag block of two or more if X is to be comprised " _
    & VBA.Chr(13) & "of a number of different contiguous ranges ", _
    Title:="Principal Components for " & sceName & ", X block # " _
    & xblock, _
    Type:=8)
    
    titlrows = 0
    For i = 1 To 5
        whatinit = VarType(rawRange(i, 1))
        If whatinit = 8 Then titlrows = titlrows + 1 Else _
        titlrows = titlrows
    Next i

    rawRange.Worksheet.Activate
    rawRange.Select
    Dim redoRange As Variant
    With Selection
      numRows = Selection.Rows.Count - titlrows
      numCols = Selection.Columns.Count
      If xblock = 1 Then numXRows = numRows
      If xblock > 1 And Not numRows = numXRows Then
        redoRange = MsgBox("X block #" & kountr & _
             "is not same length as X block #1" _
             & VBA.Chr(13) & "Block#1 has " & titlerows & " title rows and " _
             & numXRows & " data rows", 2, _
            "Uneven length")
        If redoRange = 4 Then: GoTo xnocontigline
        ElseIf redoRange = 3 Then: GoTo finexit
      End If

      Call appendpc(numRows, numCols, raw, titlrows, titles, kountr)
    End With
    
    kountr = kountr + numCols
    goon = MsgBox("More X's?", 4, _
      "(Have chosen " & kountr & " X column(s) so far)")
   
  Loop
numCols = kountr
End If
     
Call xdevmean(numRows, numCols, raw, x, sumxsq, stddev, xnorm, variance)

Call COV(numRows, numCols, x, vcov, denompc1, denompc2, denom, corr)

'covariance first
Call makeigen(numRows, numCols, vcov, a, b, adiag)
 
Call makescor(numRows, numCols, a, x, scores, adiag, b)

Dim cumtot As Variant
Call output1(numRows, numCols, a, x, scores, adiag, b, _
   vcov, raw, titlrows, titles, sceName, eigentot, eigenind, eigencum, _
   cumtot, outFrame)
   
'correlation next
Call makeigen(numRows, numCols, corr, a, b, adiag)
 
Call makescor(numRows, numCols, a, xnorm, scores, adiag, b)

Call output2(numRows, numCols, a, x, scores, adiag, b, _
   corr, raw, titlrows, titles, sceName, eigentot, eigenind, eigencum, _
   cumtot, outFrame)
exitLine:

If redoRange = 3 And Err.Number = 9 Then: GoTo finexit
If redoRange = 5 And Err.Number = 9 Then
    bombed = MsgBox("Principal components technique requires X columns of same length" _
          , , "Cannot compute")
    GoTo finexit
End If
If titlrows = 0 Then
    bombed = MsgBox("One or more Xcolumns lacks title(s), please try again " _
          , 5, "Titles missing")
    If bombed = 4 Then GoTo xstart
    If bombed = 2 Then GoTo finexit
End If


Select Case Err.Number
  Case 13
    redoRange = MsgBox("No Valid Entry", 2, _
            "All Possible Subsets")
    If redoRange = 4 Then
      Resume
    ElseIf redoRange = 3 Then: GoTo finexit
    ElseIf redoRange = 5 Then: Resume Next
    End If
   Case 1004
   Dim cleanUp As Variant
    cleanUp = MsgBox("Duplicate sheet name(s):" _
       & VBA.Chr(13) & VBA.Chr(13) & "Prin Comp " & sceName & " VCOV and/or " _
                           & "Prin Comp " & sceName & " CORR" _
       & VBA.Chr(13) & VBA.Chr(13) & "Please either:" _
       & VBA.Chr(13) & "     Re-run with different scenario name" _
       & VBA.Chr(13) & "     Delete old sheets or" _
       & VBA.Chr(13) & "     Rename old sheets", , "Duplicate sheet names")
   Case Is <> 0
      bombed = MsgBox("Error # " & Err & ": " _
      & VBA.Chr(13) & Error(Err), , "Error condition forced exit")
 End Select

'added 20230309--add plot of cumulative variation
'correlation based was last sheet added
On Error Resume Next

Dim corrSheet, mySheet As Worksheet
For Each mySheet In ActiveWorkbook.Sheets
    Debug.Print (mySheet.Name)
    Debug.Print ("Prin Comp " & sceName & " CORR")
    If mySheet.Name = "Prin Comp " & sceName & " CORR" Then
        Set corrSheet = mySheet
        GoTo corrSheetLine
    End If
Next mySheet

'activate correlation-based PCA sheet and go to cell A1
corrSheetLine:
corrSheet.Activate
Application.Goto (Cells(1, 1))

'find where eigenvectors are
Cells.Find(What:="eigenvectors", After:=ActiveCell, LookIn:=xlFormulas, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False).Activate
'what row
Dim eigenvaluePctRow As Long
eigenvaluePctRow = ActiveCell.Row - 3
'how many columns
Dim howManyPCs As Long
howManyPCs = 0
While Cells(eigenvaluePctRow, howManyPCs + 1) <> ""
    howManyPCs = howManyPCs + 1
Wend
    
'make chart
On Error Resume Next
Call makePcaCumVar(eigenvaluePctRow, howManyPCs)

finexit:

End Sub
Sub Filler(m, n, raw, titlrows, titles)

ReDim raw(1 To m, 1 To n) As Double
If titlrows > 0 Then ReDim titles(1 To titlrows, 1 To n) As String

Dim i As Integer
Dim j As Integer
Dim kountr As Integer

For i = 1 To m
   For j = kountr + 1 To kountr + n
   raw(i, j) = Selection.Cells(i + titlrows, j).Value
   Next j
Next i
 
If titlrows > 0 Then
For i = 1 To titlrows
    For j = 1 To n
       titles(i, j) = Selection.Cells(i, j).Value
    Next j
Next i
End If
    
End Sub
Sub appendpc(m, n, raw, titlrows, titles, kountr)

ReDim Preserve raw(1 To m, 1 To n + kountr) As Double
If titlrows > 0 Then ReDim Preserve titles(1 To titlrows, _
  1 To n + kountr) _
  As String

Dim i As Integer
Dim j As Integer
Dim jj As Integer

For i = 1 To m
   For j = 1 + kountr To n + kountr
       jj = j - kountr
   raw(i, j) = Selection.Cells(i + titlrows, jj).Value
   Next j
Next i
 
If titlrows > 0 Then
For i = 1 To titlrows
    For j = 1 + kountr To n + kountr
        jj = j - kountr
        titles(i, j) = Selection.Cells(i, jj).Value
    Next j
Next i
End If
    
End Sub
Sub xdevmean(m, n, raw, x, sumxsq, stddev, xnorm, variance)
ReDim Xcoltot(1 To n) As Double
ReDim x(1 To m, 1 To n) As Double
ReDim sumxsq(1 To n) As Double
ReDim stddev(1 To n) As Double
ReDim xnorm(1 To m, 1 To n) As Double
ReDim variance(1 To n) As Double

ReDim xMean(1 To n) As Double
'
' compute the mean and standard deviation for each variable
'
Dim i As Integer
Dim j As Integer
For j = 1 To n
  Xcoltot(n) = 0
  sumxsq(n) = 0
  For i = 1 To m
    Xcoltot(j) = Xcoltot(j) + raw(i, j)
  Next i
  xMean(j) = Xcoltot(j) / m
Next j
'
' now express your X matrix in mean-deviation form
'
For j = 1 To n
   For i = 1 To m
     x(i, j) = raw(i, j) - xMean(j)
   Next i
Next j

For j = 1 To n
   For i = 1 To m
      sumxsq(j) = sumxsq(j) + (x(i, j) * x(i, j))
   Next i
   variance(j) = sumxsq(j) / (m - 1)
   stddev(j) = Sqr(variance(j))
Next j

For j = 1 To n
   For i = 1 To m
      xnorm(i, j) = x(i, j) / stddev(j)
   Next i
Next j

End Sub
Sub COV(m, n, x, vcov, denompc1, denompc2, denom, corr)
ReDim vcov(1 To n, 1 To n)
ReDim corr(1 To n, 1 To n), denom(1 To n, 1 To n)

Dim i As Integer
Dim j As Integer
Dim jj As Integer

For i = 1 To n
   For j = 1 To n
   vcov(i, j) = 0
   denompc1 = 0
   denompc2 = 0
     For jj = 1 To m
       vcov(i, j) = vcov(i, j) + (x(jj, i) * x(jj, j))
       denompc1 = denompc1 + (x(jj, i) ^ 2)
       denompc2 = denompc2 + (x(jj, j) ^ 2)
      
     Next jj
     denom(i, j) = (denompc1 * denompc2) ^ 0.5
     corr(i, j) = vcov(i, j) / denom(i, j)
     vcov(i, j) = vcov(i, j) / (m - 1)
   
   Next j
Next i
End Sub
Sub makeigen(m, n, vcov, a, b, adiag)
'
'eigen values are a, matrix of eigen vectors are b

    ReDim a(1 To n, 1 To n) As Double
    ReDim b(1 To n, 1 To n) As Double
    ReDim adiag(1 To n) As Double

    
    ' the documented function copied the input--a variance/covariance
    ' matrix--into a, so it is done with the vcov generated within
    ' the vcov matrix
    
    Dim i As Integer
    Dim j As Integer
    For i = 1 To n
        For j = 1 To n
            a(i, j) = vcov(i, j)
        Next j
    Next i
    
    ' Calculate intital and final norms. Set b to identity matrix
    Dim ANORM As Single
    Dim FNORM As Single
    Dim THR As Single
    Dim AT As Single
    
    Dim ind As Integer
    Dim I1 As Integer
    
    ANORM = 0#
    For i = 1 To n
        For j = 1 To n
            If (i = j) Then
                b(i, j) = 1#
            Else
                b(i, j) = 0#
                ANORM = ANORM + a(i, j) * a(i, j)
            End If
        Next j
    Next i
    ANORM = Sqr(ANORM)
    FNORM = ANORM * 0.000000001 / n
    
    ' Initialize indicators and compute threshold
    THR = ANORM
23:
    THR = THR / n
    
    Dim AL As Single
    Dim AM As Single
    Dim AO As Single
    Dim SINX As Single
    Dim SINX2 As Single
    Dim COSX As Single
    Dim COSX2 As Single
    Dim bt As Single
    Dim XT As Single
    
    Dim k As Integer
    
    Do ' 3
       ind = 0
        ' Scan down columns for off-diagonal elements greater than or equal to threshold
        For i = 2 To n
            I1 = i - 1
            For j = 1 To I1
                If (Abs(a(j, i)) - THR) < 0 Then
                    GoTo Next_Column
                End If
                ' Compute sine and cosine
                ind = 1
                AL = -a(j, i)
                AM = (a(j, j) - a(i, i)) / 2#
                AO = AL / Sqr(AL * AL + AM * AM)
                If (AM) < 0 Then
                    AO = -AO
                End If
                SINX = AO / Sqr(2# * (1# + Sqr(1# - AO * AO)))
                SINX2 = SINX * SINX
                COSX = Sqr(1# - SINX2)
                COSX2 = COSX * COSX
                ' Rotate columns i and j
                For k = 1 To n
                    If (k - j) <> 0 Then
                        If (k - i) <> 0 Then
                            AT = a(k, j)
                            a(k, j) = AT * COSX - a(k, i) * SINX
                            a(k, i) = AT * SINX + a(k, i) * COSX
                         End If
                    End If
                    bt = b(k, j)
                    b(k, j) = bt * COSX - b(k, i) * SINX
                    b(k, i) = bt * SINX + b(k, i) * COSX
                Next k
                XT = 2# * a(j, i) * SINX * COSX
                AT = a(j, j)
                bt = a(i, i)
                a(j, j) = AT * COSX2 + bt * SINX2 - XT
                a(i, i) = AT * SINX2 + bt * COSX2 + XT
                a(j, i) = (AT - bt) * SINX * COSX + a(j, i) * (COSX2 - SINX2)
                a(i, j) = a(j, i)
                For k = 1 To n
                    a(j, k) = a(k, j)
                    a(i, k) = a(k, i)
                Next k
Next_Column:
            Next j
        Next i
    Loop While (ind > 0)
    If ((THR - FNORM) > 0) Then GoTo 23
       
    ' Sort Eigenvalues and eigenvectors
    For i = 2 To n
        j = i
SortNextColumn:
        If ((a(j - 1, j - 1) - a(j, j)) < 0) Then
            AT = a(j - 1, j - 1)
            a(j - 1, j - 1) = a(j, j)
            a(j, j) = AT
            For k = 1 To n
                AT = b(k, j - 1)
                b(k, j - 1) = b(k, j)
                b(k, j) = AT
            Next k
            j = j - 1
            If ((j - 1) > 0) Then GoTo SortNextColumn
        End If
    Next i

For i = 1 To n
    adiag(i) = a(i, i)
Next i

    
End Sub
Sub makescor(m, n, a, x, scores, adiag, b)
ReDim scores(1 To m, 1 To n)
 
 Dim i As Integer
 Dim j As Integer
 Dim jj As Integer
 
For i = 1 To m
  For j = 1 To n
  scores(i, j) = 0
     For jj = 1 To n
        scores(i, j) = scores(i, j) + (x(i, jj) * b(jj, j))
     Next jj
  Next j
Next i
End Sub
Sub output1(m, n, a, x, scores, adiag, b, vcov, raw, titlrows, _
    titles, sceName, eigentot, eigenind, eigencum, cumtot, outFrame)
'
' output Macro
'
Dim startcel As Long
   
Dim resltSht As Worksheet
Set resltSht = Application.Sheets.Add
resltSht.Activate

Dim i As Integer
Dim j As Integer
With Selection
   ActiveSheet.Name = "Prin Comp " & sceName & " VCOV"
   For i = 1 To 1
     For j = 1 To n
       Selection.Cells(i, j).Value = "Pvcov" & sceName & j
       Selection.Cells(i, j).Font.Bold = True
       Selection.Cells(i, j).HorizontalAlignment = xlRight
                  
       With Selection.Cells(i, j).Interior
        .ColorIndex = 8
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
       End With
     Next j
   Next i
End With

startcel = 1
With Selection
   For i = 1 To m
     For j = 1 To n
       Selection.Cells(startcel + i, j).Value = scores(i, j)
       With Selection.Cells(startcel + i, j).Interior
        .ColorIndex = 8
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
       End With
       ActiveSheet.Cells(startcel + i, j).NumberFormat = "0.0000"
     Next j
   Next i
End With
   
startcel = startcel + m + 3
ActiveSheet.Cells(startcel, 1) = "Variance-Covariance Matrix"
ActiveSheet.Cells(startcel, 1).Font.Bold = True
ActiveSheet.Cells(startcel, 1).Font.Italic = True

startcel = startcel + 1

For i = 1 To n
   For j = 1 To n
      ActiveSheet.Cells(startcel + i, j) = vcov(i, j)
      ActiveSheet.Cells(startcel + i, j).NumberFormat = "0.0000"
   Next j
Next i

startcel = startcel + n + 3
ActiveSheet.Cells(startcel, 1).Value = "EigenValues"
ActiveSheet.Cells(startcel, 1).Font.Bold = True
ActiveSheet.Cells(startcel, 1).Font.Italic = True

eigentot = 0
startcel = startcel + 2
For j = 1 To n
   ActiveSheet.Cells(startcel, j).Value = adiag(j)
   ActiveSheet.Cells(startcel, j).NumberFormat = "0.0000"
   eigentot = eigentot + adiag(j)
Next j

startcel = startcel + 3
ActiveSheet.Cells(startcel, 1).Value = "Eigenvalues incremental"
ActiveSheet.Cells(startcel, 1).Font.Bold = True
ActiveSheet.Cells(startcel, 1).Font.Italic = True

startcel = startcel + 2
For j = 1 To n
   ActiveSheet.Cells(startcel, j).Value = adiag(j) / eigentot
   ActiveSheet.Cells(startcel, j).NumberFormat = "0.00%"
Next j

startcel = startcel + 3
ActiveSheet.Cells(startcel, 1).Value = "Eigenvalues cumulative"
ActiveSheet.Cells(startcel, 1).Font.Bold = True
ActiveSheet.Cells(startcel, 1).Font.Italic = True

cumtot = 0
startcel = startcel + 2
For j = 1 To n
    cumtot = cumtot + adiag(j)
   ActiveSheet.Cells(startcel, j).Value = cumtot / eigentot
   ActiveSheet.Cells(startcel, j).NumberFormat = "0.00%"
Next j

  
startcel = startcel + 3
ActiveSheet.Cells(startcel, 1).Value = "Eigenvectors (Matrix of)"
ActiveSheet.Cells(startcel, 1).Font.Bold = True
ActiveSheet.Cells(startcel, 1).Font.Italic = True

startcel = startcel + 1

'added block 1
startcel = startcel + 1
For i = 1 To 1
   For j = 1 To n
      Selection.Cells(startcel, j).Value = "Pvcov" & sceName & j
      ActiveSheet.Cells(startcel, j).Font.Bold = True
   Next j
Next i
'end of added block 1

'revised next block
For i = 1 To n
  For j = 1 To n + 1
    If j <= n Then
    ActiveSheet.Cells(startcel + i, j).Value = b(i, j)
    ActiveSheet.Cells(startcel + i, j).NumberFormat = "0.0000"
    Else
    ActiveSheet.Cells(startcel + i, j).Value = titles(1, i)
    ActiveSheet.Cells(startcel + i, j).HorizontalAlignment = xlRight
    ActiveSheet.Cells(startcel + i, j).Font.Bold = True
    End If
  Next j
Next i

startcel = startcel + n + 3
ActiveSheet.Cells(startcel, 1).Value = "Derived from Input Data:"
ActiveSheet.Cells(startcel, 1).Font.Bold = True
ActiveSheet.Cells(startcel, 1).Font.Italic = True

If titlrows > 0 Then
startcel = startcel + 1
For i = 1 To titlrows
  For j = 1 To n
    ActiveSheet.Cells(startcel + i, j).Value = titles(i, j)
    ActiveSheet.Cells(startcel + i, j).HorizontalAlignment = xlRight
    ActiveSheet.Cells(startcel + i, j).Font.Bold = True
  Next j
Next i
Else: startcel = startcel + 1
End If

startcel = startcel + titlrows
For i = 1 To m
  For j = 1 To n
    ActiveSheet.Cells(startcel + i, j).Value = raw(i, j)
  Next j
Next i

Set outFrame = Range("A1", ActiveSheet.Cells(startcel + m + 2, n))
outFrame.AutoFormat Format:=xlRangeAutoFormatSimple, Number:=True, Font _
        :=False, Alignment:=False, Border:=False, Pattern:=False, Width:=True
Range("A1", "A1").ColumnWidth = Range("b1", "b1").ColumnWidth
ActiveSheet.Cells(startcel + m + 2, 1) = "Eigenvalue routines derived from http://www.geol.pdx.edu/Courses/g423/Programs/SymmetricEigenvalue.bas"

End Sub
Sub output2(m, n, a, x, scores, adiag, b, corr, raw, titlrows, _
    titles, sceName, eigentot, eigenind, eigencum, cumtot, outFrame)
'
' output Macro
'
Dim startcel As Long
   
Dim resltSht As Worksheet
Set resltSht = Application.Sheets.Add
resltSht.Activate

Dim i As Integer
Dim j As Integer
With Selection
   ActiveSheet.Name = "Prin Comp " & sceName & " CORR"
   For i = 1 To 1
     For j = 1 To n
       Selection.Cells(i, j).Value = "Pcorr" & sceName & j
       Selection.Cells(i, j).Font.Bold = True
       Selection.Cells(i, j).HorizontalAlignment = xlRight
                  
       With Selection.Cells(i, j).Interior
        .ColorIndex = 6
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
       End With
     Next j
   Next i
End With

startcel = 1
With Selection
   For i = 1 To m
     For j = 1 To n
       Selection.Cells(startcel + i, j).Value = scores(i, j)
       With Selection.Cells(startcel + i, j).Interior
        .ColorIndex = 6
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
       End With
    ActiveSheet.Cells(startcel + i, j).NumberFormat = "0.0000"
     Next j
   Next i
End With
   
startcel = startcel + m + 3
ActiveSheet.Cells(startcel, 1) = "Correlation Matrix"
ActiveSheet.Cells(startcel, 1).Font.Bold = True
ActiveSheet.Cells(startcel, 1).Font.Italic = True

startcel = startcel + 1

For i = 1 To n
   For j = 1 To n
      ActiveSheet.Cells(startcel + i, j) = corr(i, j)
      ActiveSheet.Cells(startcel + i, j).NumberFormat = "0.0000"
   Next j
Next i

startcel = startcel + n + 3
ActiveSheet.Cells(startcel, 1).Value = "Eigenvalues"
ActiveSheet.Cells(startcel, 1).Font.Bold = True
ActiveSheet.Cells(startcel, 1).Font.Italic = True

eigentot = 0
startcel = startcel + 2
For j = 1 To n
   ActiveSheet.Cells(startcel, j).Value = adiag(j)
   ActiveSheet.Cells(startcel, j).NumberFormat = "0.0000"
   eigentot = eigentot + adiag(j)
Next j

startcel = startcel + 3
ActiveSheet.Cells(startcel, 1).Value = "Eigenvalues incremental"
ActiveSheet.Cells(startcel, 1).Font.Bold = True
ActiveSheet.Cells(startcel, 1).Font.Italic = True

startcel = startcel + 2
For j = 1 To n
   ActiveSheet.Cells(startcel, j).Value = adiag(j) / eigentot
   ActiveSheet.Cells(startcel, j).NumberFormat = "0.00%"
Next j

startcel = startcel + 3
ActiveSheet.Cells(startcel, 1).Value = "Eigenvalues cumulative"
ActiveSheet.Cells(startcel, 1).Font.Bold = True
ActiveSheet.Cells(startcel, 1).Font.Italic = True

cumtot = 0
startcel = startcel + 2
For j = 1 To n
    cumtot = cumtot + adiag(j)
   ActiveSheet.Cells(startcel, j).Value = cumtot / eigentot
   ActiveSheet.Cells(startcel, j).NumberFormat = "0.00%"
Next j

  
startcel = startcel + 3
ActiveSheet.Cells(startcel, 1).Value = "Eigenvectors (Matrix of)"
ActiveSheet.Cells(startcel, 1).Font.Bold = True
ActiveSheet.Cells(startcel, 1).Font.Italic = True

startcel = startcel + 1

'added block 1
startcel = startcel + 1
For i = 1 To 1
   For j = 1 To n
      Selection.Cells(startcel, j).Value = "Pcorr" & sceName & j
      ActiveSheet.Cells(startcel, j).Font.Bold = True
   Next j
Next i
'end of added block 1

'revised next block
For i = 1 To n
  For j = 1 To n + 1
    If j <= n Then
    ActiveSheet.Cells(startcel + i, j).Value = b(i, j)
    ActiveSheet.Cells(startcel + i, j).NumberFormat = "0.0000"
    Else
    ActiveSheet.Cells(startcel + i, j).Value = titles(1, i)
    ActiveSheet.Cells(startcel + i, j).HorizontalAlignment = xlRight
    ActiveSheet.Cells(startcel + i, j).Font.Bold = True
    End If
  Next j
Next i

startcel = startcel + n + 3
ActiveSheet.Cells(startcel, 1).Value = "Derived from Input Data:"
ActiveSheet.Cells(startcel, 1).Font.Bold = True
ActiveSheet.Cells(startcel, 1).Font.Italic = True

If titlrows > 0 Then
startcel = startcel + 1
For i = 1 To titlrows
  For j = 1 To n
    ActiveSheet.Cells(startcel + i, j).Value = titles(i, j)
    ActiveSheet.Cells(startcel + i, j).HorizontalAlignment = xlRight
    ActiveSheet.Cells(startcel + i, j).Font.Bold = True
  Next j
Next i
Else: startcel = startcel + 1
End If

startcel = startcel + titlrows
For i = 1 To m
  For j = 1 To n
    ActiveSheet.Cells(startcel + i, j).Value = raw(i, j)
  Next j
Next i

Set outFrame = Range("A1", ActiveSheet.Cells(startcel + m + 2, n))
outFrame.AutoFormat Format:=xlRangeAutoFormatSimple, Number:=True, Font _
        :=False, Alignment:=False, Border:=False, Pattern:=False, Width:=True
Range("A1", "A1").ColumnWidth = Range("b1", "b1").ColumnWidth

ActiveSheet.Cells(startcel + m + 2, 1) = "Eigenvalue routines derived from http://www.geol.pdx.edu/Courses/g423/Programs/SymmetricEigenvalue.bas"
End Sub

Sub makePcaCumVar(eigenvaluePctRow, howManyPCs)
    'range for eigenvalues
    Dim eigenvalueRange As Range
    Set eigenvalueRange = Range(Cells(eigenvaluePctRow, 1), Cells(eigenvaluePctRow, howManyPCs))
    'add the chart
    ActiveSheet.Shapes.AddChart.Select
    ActiveChart.ChartType = xlLineMarkers
    ActiveChart.SetSourceData Source:=eigenvalueRange
    'drop the legend
    ActiveChart.Legend.Select
    Selection.Delete
    'add the title
    ActiveChart.SetElement (msoElementChartTitleAboveChart)
    ActiveChart.ChartTitle.Text = _
        "% Variation Captured by PC's" & Chr(13) & "(Cumulative Eigenvectors)"
    '2nd line of title is small font
    With Selection.Format.TextFrame2.TextRange.Characters(30, 25).Font
        .Size = 12
    End With
    'max out at 100%
    ActiveChart.Axes(xlValue).MaximumScale = 1
    ActiveChart.Axes(xlValue).MinimumScale = 0

End Sub