Celebrate National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

Sort a multi-dimensional (4 column) array

Posted on 2012-04-03
10
Medium Priority
?
239 Views
Last Modified: 2012-04-03
I need to sort a multi-dimension array that has 4 columns,

The array is created in VBA based on a dynamic named range.

I got all the way of creating the array from the named range.

That attached file better shows what I'm trying to accomplish.
Book1.xls
0
Comment
Question by:mcnuttlaw
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 5
  • 3
  • 2
10 Comments
 
LVL 49

Expert Comment

by:Martin Liss
ID: 37802289
Private Sub CommandButton1_Click()
DoSort
End Sub

Open in new window


In Module1


Sub DoSort()

    Range("A:D").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A:D").Select
    ActiveSheet.Paste
    Columns("C:C").Select
    Application.CutCopyMode = False
    Range("A:D").Sort Key1:=Range("C1"), Order1:=xlAscending, Header:= _
        xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
End Sub

Open in new window

0
 
LVL 2

Author Comment

by:mcnuttlaw
ID: 37802831
Need to sort a named range.
0
 
LVL 49

Expert Comment

by:Martin Liss
ID: 37802905
So are you saying that my code didn't work?
0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 2

Author Comment

by:mcnuttlaw
ID: 37803461
I don't want to select the A:D columns because there are hundreds of rows before and after the named range (see my example file) that should not even be included in the sort.

I only want to sort the named range that can be in the middle of the sheet.
0
 
LVL 14

Expert Comment

by:Tommy Kinard
ID: 37803620
I think this will work, I did it the long way but i know it works. Let me know if you want it different.

Option Explicit

Sub calcResults()
    Dim ResultSheet As Worksheet
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim lastRow As Long
    Dim myArray As Variant
   
    Set wkb = ThisWorkbook
    Set wks = wkb.Sheets("Sheet1")
   
    lastRow = wks.Range("B" & wks.Rows.Count).End(xlUp).Row
   
    ThisWorkbook.Names.Add Name:="Results", RefersTo:=wks.Range("A" & (lastRow + 1) & ":D" & (lastRow + 18)), Visible:=True
   
    myArray = Application.Transpose(Range("Results"))
    'added from here down
    Dim Id() As Long
    Dim mI As Long
    ReDim Id(UBound(myArray, 2))
    For mI = 1 To UBound(myArray, 2)
        Id(mI) = mI
    Next
    ShellSort Id, myArray
    ThisWorkbook.Worksheets.Add
    Set ResultSheet = Worksheets.Add
    ResultSheet.Name = "Results"
    With ThisWorkbook.Sheets("Results")
        For mI = 1 To UBound(myArray, 2)
            .Cells(mI, 1) = myArray(1, Id(mI))
            .Cells(mI, 2) = myArray(2, Id(mI))
            .Cells(mI, 3) = myArray(3, Id(mI))
            .Cells(mI, 4) = myArray(4, Id(mI))
        Next
    End With
End Sub
Private Sub ShellSort(iIds&(), Arr)
    Dim mK&
    Dim I As Integer, MaxLimit&
    Dim J3 As Integer
    MaxLimit = UBound(Arr, 2)
    For I = 1 To MaxLimit - 1
        For J3 = I + 1 To MaxLimit
            If Arr(3, iIds(J3)) <= Arr(3, iIds(I)) Then
                mK = iIds(J3)
                iIds(J3) = iIds(I)
                iIds(I) = mK
            End If
        Next
    Next
End Sub
0
 
LVL 2

Author Comment

by:mcnuttlaw
ID: 37803692
It does work.

One more question.

Possible to exlude any rows with a zero value from the sort into the Results tab?
0
 
LVL 14

Accepted Solution

by:
Tommy Kinard earned 2000 total points
ID: 37803700
Well Of course! Keep in mind it is sorting on column 3 only.

Option Explicit

Sub calcResults()
    Dim ResultSheet As Worksheet
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim lastRow As Long
    Dim myArray As Variant
   
    Set wkb = ThisWorkbook
    Set wks = wkb.Sheets("Sheet1")
   
    lastRow = wks.Range("B" & wks.Rows.Count).End(xlUp).Row
   
    ThisWorkbook.Names.Add Name:="Results", RefersTo:=wks.Range("A" & (lastRow + 1) & ":D" & (lastRow + 18)), Visible:=True
   
    myArray = Application.Transpose(Range("Results"))
    'added from here down
    Dim Id() As Long
    Dim mI As Long, mN As Long
    ReDim Id(UBound(myArray, 2))
    For mI = 1 To UBound(myArray, 2)
        Id(mI) = mI
    Next
    ShellSort Id, myArray
    ThisWorkbook.Worksheets.Add
    Set ResultSheet = Worksheets.Add
    ResultSheet.Name = "Results"
    mN = 1
    With ThisWorkbook.Sheets("Results")
        For mI = 1 To UBound(myArray, 2)
            If myArray(3, Id(mI)) <> 0 Then
                .Cells(mN, 1) = myArray(1, Id(mI))
                .Cells(mN, 2) = myArray(2, Id(mI))
                .Cells(mN, 3) = myArray(3, Id(mI))
                .Cells(mN, 4) = myArray(4, Id(mI))
                mN = mN + 1
            End If
        Next
    End With
End Sub
Private Sub ShellSort(iIds&(), Arr)
    Dim mK&
    Dim I As Integer, MaxLimit&
    Dim J3 As Integer
    MaxLimit = UBound(Arr, 2)
    For I = 1 To MaxLimit - 1
        For J3 = I + 1 To MaxLimit
            If Arr(3, iIds(J3)) <= Arr(3, iIds(I)) Then
                mK = iIds(J3)
                iIds(J3) = iIds(I)
                iIds(I) = mK
            End If
        Next
    Next
End Sub
0
 
LVL 2

Author Comment

by:mcnuttlaw
ID: 37803804
Very nice.

One more question.

Is there a variable to set to sort either ascending or descending order?
0
 
LVL 14

Assisted Solution

by:Tommy Kinard
Tommy Kinard earned 2000 total points
ID: 37803841
If Arr(3, iIds(J3)) <= Arr(3, iIds(I)) Then  'Ascending
 If Arr(3, iIds(J3)) >= Arr(3, iIds(I)) Then 'Descending

I revised the sort routine to include the up or down choice AND you can choose which column to sort on, if it is column 3 you don't have to enter the column number of course.

Private Sub ShellSort(iIds&(), Arr, Up As Boolean, Optional Clmn As Long = 3)
    Dim mK&
    Dim I As Integer, MaxLimit&
    Dim J3 As Integer
    MaxLimit = UBound(Arr, 2)
    For I = 1 To MaxLimit - 1
        For J3 = I + 1 To MaxLimit
            If Up Then
                If Arr(Clmn, iIds(J3)) <= Arr(Clmn, iIds(I)) Then
                    mK = iIds(J3)
                    iIds(J3) = iIds(I)
                    iIds(I) = mK
                End If
            Else
                If Arr(Clmn, iIds(J3)) >= Arr(Clmn, iIds(I)) Then
                    mK = iIds(J3)
                    iIds(J3) = iIds(I)
                    iIds(I) = mK
                End If
           
            End If
        Next
    Next
End Sub
0
 
LVL 2

Author Comment

by:mcnuttlaw
ID: 37803872
This is exactly what I was looking for.  Thank you.


btw - if you ever come up with the "short" version, be sure to let me know.
0

Featured Post

What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

730 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question