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

E

eurobonds

New Member
Joined
Mar 22, 2016
Messages
35
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

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Sort by date Sort by votes
Just a thought, if you want to sort by largest absolute values while keeping the sign, might you try running the quick sort algorithm on the absolute values of the array entries? i.e. abs(varray(tmplow)) and pivot = (abs(varray((inlow+inhi)/2)? That will sort the array by absolute magnitude while maintaining the signs?
 
Upvote 0
ronga2001 said:
Just a thought, if you want to sort by largest absolute values while keeping the sign, might you try running the quick sort algorithm on the absolute values of the array entries? i.e. abs(varray(tmplow)) and pivot = (abs(varray((inlow+inhi)/2)? That will sort the array by absolute magnitude while maintaining the signs?
Click to expand...
Here's an implementation of the quicksort algorithm cobbled together from an old code of mine that will sort by absolute value:

VBA Code: 
Public Sub Main()
Dim vbArray() As Integer, i As Integer

'populate vbArray

Call QuickSort(vbArray, LBound(vbArray), UBound(vbArray))

End Sub
  
Sub QuickSort(ByRef randArray() As Integer, left As Integer, right As Integer)
Dim loc As Integer
If left < right Then
    loc = partition(randArray, left, right)
    Call QuickSort(randArray, left, loc - 1)
    Call QuickSort(randArray, loc + 1, right)
End If
End Sub

Function partition(ByRef vbArray() As Integer, lowerbound As Integer, upperbound As Integer)
Dim pivot As Integer, vbStart As Integer, vbEnd As Integer
pivot = vbArray(lowerbound)
vbStart = lowerbound
vbEnd = upperbound
While vbStart < vbEnd
    While Abs(vbArray(vbStart)) <= Abs(pivot)
        vbStart = vbStart + 1
    Wend
    While Abs(vbArray(vbEnd)) > Abs(pivot)
        vbEnd = vbEnd - 1
    Wend
    If vbStart < vbEnd Then
       Call swap(vbArray, vbStart, vbEnd)
    End If
Wend
Call swap(vbArray, lowerbound, vbEnd)
partition = vbEnd
End Function

Sub swap(ByRef randArray() As Integer, firstNumber As Integer, secNumber As Integer)
Dim temp As Integer
temp = randArray(firstNumber)
randArray(firstNumber) = randArray(secNumber)
randArray(secNumber) = temp
End Sub
 
Upvote 0
ronga2001 said:
Here's an implementation of the quicksort algorithm cobbled together from an old code of mine that will sort by absolute value:

VBA Code: 
Public Sub Main()
Dim vbArray() As Integer, i As Integer

'populate vbArray

Call QuickSort(vbArray, LBound(vbArray), UBound(vbArray))

End Sub
 
Sub QuickSort(ByRef randArray() As Integer, left As Integer, right As Integer)
Dim loc As Integer
If left < right Then
    loc = partition(randArray, left, right)
    Call QuickSort(randArray, left, loc - 1)
    Call QuickSort(randArray, loc + 1, right)
End If
End Sub

Function partition(ByRef vbArray() As Integer, lowerbound As Integer, upperbound As Integer)
Dim pivot As Integer, vbStart As Integer, vbEnd As Integer
pivot = vbArray(lowerbound)
vbStart = lowerbound
vbEnd = upperbound
While vbStart < vbEnd
    While Abs(vbArray(vbStart)) <= Abs(pivot)
        vbStart = vbStart + 1
    Wend
    While Abs(vbArray(vbEnd)) > Abs(pivot)
        vbEnd = vbEnd - 1
    Wend
    If vbStart < vbEnd Then
       Call swap(vbArray, vbStart, vbEnd)
    End If
Wend
Call swap(vbArray, lowerbound, vbEnd)
partition = vbEnd
End Function

Sub swap(ByRef randArray() As Integer, firstNumber As Integer, secNumber As Integer)
Dim temp As Integer
temp = randArray(firstNumber)
randArray(firstNumber) = randArray(secNumber)
randArray(secNumber) = temp
End Sub
Click to expand...
thank you!
 
Upvote 0
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
14
Views
6K
Fibo
F
R
  • Solved
VBA can't assign function return value to array
Replies
9
Views
503
ronga2001
R
W
  • Solved
Runtime Error 5 on very complicated sheet (to me anyway :) )
2 3
Replies
26
Views
3K
Woodpusher147
W
T
  • Question Question
Quicksort
Replies
5
Views
4K
Fluff
Fluff
Darren Bartrup
  • Solved
UDF to separate date ranges where they overlap.
Replies
5
Views
2K
pgc01
P

Forum statistics

Threads
1,223,702
Messages
6,173,967
Members
452,539
Latest member
delvey

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