Function to return array of 10 largest absolute values while maintaining sign

E

eurobonds

New Member
Joined
Mar 22, 2016
Messages
34
Greetings:

Looking for some help in adding some functionality to my worksheet (and possibly making it more efficient). I've cobbled together these sort algorithms from various authors and am struggling with adapting them for 2D arrays.

End goal is to explain year-over-year changes for specific financial statement lines by pulling in project details from various reports. Each year will have different projects driving the changes, and the changes could be positive or negative. I currently generate a 1D array of numerical changes from the detail report, sort it from high to low, loop through first 10 items in array to print to summary sheet, then add an INDEX MATCH on the numerical change to pull in the project name. I realize this will generate an error if two projects have the same change, which is why I want to update this to a 2D array.

I currently can print my array in either ascending or descending order, but I would like to see the top ten largest ABSOLUTE changes (while still displaying the original sign of the change--positive or negative). I feel like it would be easy to populate my array with only absolute values, but then sorting and printing the top values would not make logical sense.

Features to add in order of priority:
  • function to return array of 10 largest absolute values while maintaining sign
  • 2D array of changes where "column" 1 is the project and "column" 2 is the change
  • 2D array sort algorithms to sort change "column" as described above
Subs and functions I have so far:

VBA Code: 
Sub TestPrintArray()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    
    Dim wsS15fx As Worksheet
    Set wsS15fx = Worksheets("XXXXXXXXXXXXXXXX")
    Dim wsReconfx As Worksheet
    Set wsReconfx = Worksheets("YYYYYYYYYYYYY")
    Dim arTestArray() As Variant
    Dim i      As Integer
    
    arTestArray = GetLargestAbsoluteChanges(wsS15fx.Range("$J$548:$J$5000"), _
                  wsReconfx.Range("B1"), wsReconfx.Range("B4"))
    For i = LBound(arTestArray) To 9
        wsReconfx.Range("G" & (i + 30)) = arTestArray(i)
        wsReconfx.Range("G" & (i + 30)).Offset(0, -1).Formula = "=INDEX('S15 - Depr by Plant Acct'!$D:$D,MATCH(G" & _
                             (i + 30) & ",'S15 - Depr by Plant Acct'!$J:$J,0))"
        wsReconfx.Range("G" & (i + 30)).Offset(0, -1).Copy
        wsReconfx.Range("G" & (i + 30)).Offset(0, -1).PasteSpecial Paste:=xlPasteValues
        wsReconfx.Range("G" & (i + 30)).Value = wsReconfx.Range("G" & (i + 30)) / 1000
    Next
    
    arTestArray = GetLargestAbsoluteChanges(wsS15fx.Range("$K$548:$K$5000"), _
                  wsReconfx.Range("B1"), wsReconfx.Range("B4"))
    For i = LBound(arTestArray) To 9
        wsReconfx.Range("I" & (i + 30)) = arTestArray(i)
        wsReconfx.Range("I" & (i + 30)).Offset(0, -1).Formula = "=INDEX('S15 - Depr by Plant Acct'!$D:$D,MATCH(I" & _
                             (i + 30) & ",'S15 - Depr by Plant Acct'!$K:$K,0))"
        wsReconfx.Range("I" & (i + 30)).Offset(0, -1).Copy
        wsReconfx.Range("I" & (i + 30)).Offset(0, -1).PasteSpecial Paste:=xlPasteValues
        wsReconfx.Range("I" & (i + 30)).Value = wsReconfx.Range("I" & (i + 30)) / 1000
    Next
    
    arTestArray = GetLargestAbsoluteChanges(wsS15fx.Range("$L$548:$L$5000"), _
                  wsReconfx.Range("B1"), wsReconfx.Range("B4"))
    For i = LBound(arTestArray) To 9
        wsReconfx.Range("K" & (i + 30)) = arTestArray(i)
        wsReconfx.Range("K" & (i + 30)).Offset(0, -1).Formula = "=INDEX('S15 - Depr by Plant Acct'!$D:$D,MATCH(K" & _
                             (i + 30) & ",'S15 - Depr by Plant Acct'!$L:$L,0))"
        wsReconfx.Range("K" & (i + 30)).Offset(0, -1).Copy
        wsReconfx.Range("K" & (i + 30)).Offset(0, -1).PasteSpecial Paste:=xlPasteValues
        wsReconfx.Range("K" & (i + 30)).Value = wsReconfx.Range("K" & (i + 30)) / 1000
    Next
    
    arTestArray = GetLargestAbsoluteChanges(wsS15fx.Range("$M$548:$M$5000"), _
                  wsReconfx.Range("B1"), wsReconfx.Range("B4"))
    For i = LBound(arTestArray) To 9
        wsReconfx.Range("M" & (i + 30)) = arTestArray(i)
        wsReconfx.Range("M" & (i + 30)).Offset(0, -1).Formula = "=INDEX('S15 - Depr by Plant Acct'!$D:$D,MATCH(M" & _
                             (i + 30) & ",'S15 - Depr by Plant Acct'!$M:$M,0))"
        wsReconfx.Range("M" & (i + 30)).Offset(0, -1).Copy
        wsReconfx.Range("M" & (i + 30)).Offset(0, -1).PasteSpecial Paste:=xlPasteValues
        wsReconfx.Range("M" & (i + 30)).Value = wsReconfx.Range("M" & (i + 30)) / 1000
    Next
    
    arTestArray = GetLargestAbsoluteChanges_LTH(wsS15fx.Range("$N$548:$N$5000"), _
                  wsReconfx.Range("B1"), wsReconfx.Range("B4"))
    For i = LBound(arTestArray) To 9
        wsReconfx.Range("O" & (i + 30)) = arTestArray(i)
        wsReconfx.Range("O" & (i + 30)).Offset(0, -1).Formula = "=INDEX('S15 - Depr by Plant Acct'!$D:$D,MATCH(O" & _
                             (i + 30) & ",'S15 - Depr by Plant Acct'!$N:$N,0))"
        wsReconfx.Range("O" & (i + 30)).Offset(0, -1).Copy
        wsReconfx.Range("O" & (i + 30)).Offset(0, -1).PasteSpecial Paste:=xlPasteValues
        wsReconfx.Range("O" & (i + 30)).Value = wsReconfx.Range("O" & (i + 30)) / 1000
    Next
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
End Sub

Public Function GetLargestAbsoluteChanges(ByRef Data As Range, InputScenario As Range, InputUtility As Range) As Variant()
    Dim cell   As Range
    Dim wsS15fx As Worksheet
    Set wsS15fx = Worksheets("S15 - Depr by Plant Acct")
    Dim arLargestChanges() As Variant
    ReDim arLargestChanges(0)
    
    For Each cell In Data
        If Not IsEmpty(cell) And cell.Value <> 0 Then 'And (cell.Value > 400000 Or cell.Value < -400000)
            If wsS15fx.Range("E" & cell.Row).Value = InputScenario.Value And _
                wsS15fx.Range("C" & cell.Row).Value = InputUtility.Value Then
                If IsEmpty(arLargestChanges(LBound(arLargestChanges))) Then
                    arLargestChanges(LBound(arLargestChanges)) = cell.Value
                Else
                    ReDim Preserve arLargestChanges(UBound(arLargestChanges) + 1)
                    arLargestChanges(UBound(arLargestChanges)) = cell.Value
                End If
            End If
        End If
    Next
    
    Call QuickSort(arLargestChanges, 0, UBound(arLargestChanges))
    Call ReverseArray(arLargestChanges)
    GetLargestAbsoluteChanges = arLargestChanges
End Function

Public Function GetLargestAbsoluteChanges_LTH(ByRef Data As Range, InputScenario As Range, InputUtility As Range) As Variant()
    Dim cell   As Range
    Dim wsS15fx As Worksheet
    Set wsS15fx = Worksheets("S15 - Depr by Plant Acct")
    Dim arLargestChanges() As Variant
    ReDim arLargestChanges(0)
    
    For Each cell In Data
        If Not IsEmpty(cell) And cell.Value <> 0 Then 'And (cell.Value > 400000 Or cell.Value < -400000)
            If wsS15fx.Range("E" & cell.Row).Value = InputScenario.Value And _
                wsS15fx.Range("C" & cell.Row).Value = InputUtility.Value Then
                If IsEmpty(arLargestChanges(LBound(arLargestChanges))) Then
                    arLargestChanges(LBound(arLargestChanges)) = cell.Value
                Else
                    ReDim Preserve arLargestChanges(UBound(arLargestChanges) + 1)
                    arLargestChanges(UBound(arLargestChanges)) = cell.Value
                End If
            End If
        End If
    Next
    
    Call QuickSort(arLargestChanges, 0, UBound(arLargestChanges))
    'Call ReverseArray(arLargestChanges)
    GetLargestAbsoluteChanges_LTH = arLargestChanges
End Function

Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
    Dim pivot  As Variant
    Dim tmpSwap As Variant
    Dim tmpLow As Long
    Dim tmpHi  As Long
    tmpLow = inLow
    tmpHi = inHi
    pivot = vArray((inLow + inHi) \ 2)
    
    While (tmpLow <= tmpHi)
        While (vArray(tmpLow) < pivot And tmpLow < inHi)
            tmpLow = tmpLow + 1
        Wend
        
        While (pivot < vArray(tmpHi) And tmpHi > inLow)
            tmpHi = tmpHi - 1
        Wend
        
        If (tmpLow <= tmpHi) Then
            tmpSwap = vArray(tmpLow)
            vArray(tmpLow) = vArray(tmpHi)
            vArray(tmpHi) = tmpSwap
            tmpLow = tmpLow + 1
            tmpHi = tmpHi - 1
        End If
    Wend
    
    If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
    If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

Public Sub ReverseArray(vArray As Variant)
    'Reverse the order of an array, so if it's already sorted from smallest to largest, it will now be sorted from largest to smallest.
    Dim vTemp  As Variant
    Dim i      As Long
    Dim iUpper As Long
    Dim iMidPt As Long
    iUpper = UBound(vArray)
    iMidPt = (UBound(vArray) - LBound(vArray)) \ 2 + LBound(vArray)
    For i = LBound(vArray) To iMidPt
        vTemp = vArray(iUpper)
        vArray(iUpper) = vArray(i)
        vArray(i) = vTemp
        iUpper = iUpper - 1
    Next i
End Sub

Current summary - can only sort asc or desc
1713801478847.png


Goal: sorted by largest absolute change but still retains original sign
1713803936864.png
 

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
You must log in or register to reply here.

Similar threads

N
  • Solved
Quick Sort for 2D Array Multiple Column Sort Ascending Descending and Transposed
2
Replies
13
Views
5K
Natas
N
W
  • Solved
Runtime Error 5 on very complicated sheet (to me anyway :) )
2 3
Replies
26
Views
3K
Woodpusher147
W
T
  • Question
Quicksort
Replies
5
Views
3K
Fluff
Fluff
Darren Bartrup
  • Solved
UDF to separate date ranges where they overlap.
Replies
5
Views
2K
pgc01
P
T
  • Solved
Array not returning expected value
Replies
4
Views
433
ToExcelOrNotToExcel
T

Forum statistics

Threads
1,215,427
Messages
6,124,831
Members
449,190
Latest member
rscraig11

Share this page

We've detected that you are using an adblocker.

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

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

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

Disable uBlock

Follow these easy steps to disable uBlock

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