Sort array .!

MyHanhCB

MyHanhCB

New Member
Joined
Feb 20, 2023
Messages
30
Office Version
  1. 2016
Platform
  1. Windows
Hello everybody. I have 1 problem.
Specifically I have 1 2D array.
"arr(1, 1) = "A": arr(1, 2) = 3 : arr(2, 1) = "B": arr(2, 2) = 1 : arr(3, 1) = "C": data(3, 2) = 5 : arr(4, 1) = "D": arr(4, 2) = 2 : arr(5, 1) = "E": arr(5, 2) = 4".
Is there a function that can sort by column 2 of an array from large to small.
desired result after running:
"arr(1, 1) = "C": arr(1, 2) = 5 : arr(2, 1) = "E": arr(2, 2) = 4 : arr(3, 1) = "A": data(3, 2) = 3 : arr(4, 1) = "D": arr(4, 2) = 2 : arr(5, 1) = "B": arr(5, 2) = 1"
thanks!
 

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
Sort by date Sort by votes
This can get very complicated. See the code suggestions here, here and here. One work around is to use the worksheet object as an intermediary in the process, which makes the code an awful lot simpler. Basically, fill your array as you have done, put it on a worksheet, sort it & then reload the array from the sheet. Compare the code below to some of the suggested worksites & you'll see what I mean.

VBA Code: 
Option Explicit
Sub testArraySort()
    Dim arr(1 To 5, 1 To 2), i As Long, ws As Worksheet
    Set ws = Worksheets("Sheet1")           '<~~ *** Change sheet name to suit ***
    
    'Fill the array as you have done
    arr(1, 1) = "A": arr(1, 2) = 3: arr(2, 1) = "B": arr(2, 2) = 1: arr(3, 1) = "C": arr(3, 2) = 5: arr(4, 1) = "D": arr(4, 2) = 2: arr(5, 1) = "E": arr(5, 2) = 4
    
    'Put it temporarily on a worksheet & sort as an in-between measure
    With ws.Cells(1)
        .Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
        .CurrentRegion.Sort Key1:=ws.Range("B1"), order1:=xlDescending, Header:=xlNo
    End With
    
    'Refill the array from the worksheet
    For i = 1 To UBound(arr)
        arr(i, 1) = ws.Cells(i, 1): arr(i, 2) = ws.Cells(i, 2)
        arr(i, 1) = ws.Cells(i, 1): arr(i, 2) = ws.Cells(i, 2)
        arr(i, 1) = ws.Cells(i, 1): arr(i, 2) = ws.Cells(i, 2)
        arr(i, 1) = ws.Cells(i, 1): arr(i, 2) = ws.Cells(i, 2)
        arr(i, 1) = ws.Cells(i, 1): arr(i, 2) = ws.Cells(i, 2)
    Next i
    
    'Test that the array has been sorted
    For i = LBound(arr) To UBound(arr)
        Debug.Print arr(i, 1); arr(i, 2)
    Next i
End Sub
 
Upvote 0
Let's say that you have the data in column A and B.
In this example the data is written to column E and F to show you the result

VBA Code: 
Sub jec()
 Dim ar, tmp, j As Long, jj As Long
 ar = Cells(1).CurrentRegion
 
 For j = 1 To UBound(ar)
   For jj = j + 1 To UBound(ar)
     If ar(j, 2) < ar(jj, 2) Then
       tmp = ar(jj, 1): ar(jj, 1) = ar(j, 1): ar(j, 1) = tmp
       tmp = ar(jj, 2): ar(jj, 2) = ar(j, 2): ar(j, 2) = tmp
     End If
    Next
 Next
 
 Cells(1, 5).Resize(UBound(ar), 2) = ar
End Sub
 
Upvote 0
jolivanes said:
How is the array populated?
Click to expand...
After I count occurrences of that 1 value. fill in the array and get the same as above. My problem is that I want to reorder the array by the value with the largest to smallest occurrence (A-Z).
 
Upvote 0
Thank you guys.
I have found a function, but using it on my machine is fine. When I switch to another machine, I get an error at
VBA Code:
Set oListStr = CreateObject("System.Collections.ArrayList")
Set oListNum = CreateObject("System.Collections.ArrayList"
VBA Code:
I'm using vb6.
VBA Code: 
Option Explicit
Function SortArray2D(ByVal sArr, ByVal aCol, Optional bHeader As Boolean = False) As Variant
  'Sort Mang 2 chieu "sArr" theo nhieu Cot
  'aCol: So hoac Mang so, so duong tu A => Z, so am tu Z => A
  'Ví du aCol:'          2:  Sort theo cot 2 tu A => Z
              '         -3:  Sort theo cot 3 tu Z => A
              'Array(2,-4): (VBA) Sort theo cot 2 tu A => Z và Sort theo cot 4 tu Z => A
              '{2,-4}:      (Cong thuc trong Sheet) Sort theo cot 2 tu A => Z và Sort theo cot 4 tu Z => A
  'bHead = True Du lieu co dong tieu de. Mac dinh bHead = False Du lieu khong co dong tieu de
  Dim aRow, Res()
  Dim uRow&, sRow&, fRow&, eRow&, fCol&, eCol&, jCol&, b&, i&, r&, n&, k&, j&, fr&
  Dim td$, tdUp$, bASC As Boolean, tmp, tmp2

  If TypeName(sArr) = "Range" Then sArr = sArr.Value
  If IsArray(sArr) = False Then Exit Function
  fRow = LBound(sArr, 1):   eRow = UBound(sArr, 1)
  fCol = LBound(sArr, 2):   eCol = UBound(sArr, 2)
  If IsArray(aCol) = False Then aCol = Array(aCol) 'Mang thu tu cot Sort
  If bHeader Then b = 1
  uRow = eRow - fRow - b
  ReDim aRow(0 - b To uRow) 'Mang thu tu dong du lieu goc
  For i = fRow To eRow
    aRow(i - fRow - b) = i
  Next i
  For n = LBound(aCol) To UBound(aCol)
    If n = LBound(aCol) Then 'Sort theo cot dau tien
      Call ChiaDuLieu(aRow, sArr, 0, uRow, aCol(n))
    Else 'Sort theo cac cot ke tiep
      fr = -1
      jCol = Abs(aCol(n - 1))
      For i = 0 To uRow - 1
        tmp = sArr(aRow(i), jCol): tmp2 = sArr(aRow(i + 1), jCol)
        If Not IsError(tmp) And Not IsError(tmp2) Then
          If fr >= 0 Then
            If tmp <> tmp2 Then
              Call ChiaDuLieu(aRow, sArr, fr, i, aCol(n))
              fr = -1
            ElseIf i = uRow - 1 Then
              Call ChiaDuLieu(aRow, sArr, fr, uRow, aCol(n))
              fr = -1
            End If
          ElseIf tmp = tmp2 Then
            fr = i
          End If
        End If
      Next i
    End If
  Next n

  k = fRow - 1
  ReDim Res(fRow To eRow, fCol To eCol) 'Mang ket qua
  For i = 0 - b To uRow
    k = k + 1
    r = aRow(i)
    For j = fCol To eCol
      Res(k, j) = sArr(r, j)
    Next j
  Next i
  SortArray2D = Res
End Function
Private Sub ChiaDuLieu(aRow, sArr, ByVal fRow&, ByVal eRow&, ByVal jCol&)
'  Dim oListStr As Object, oListNum As Object
  Dim aErr, aEmp, aNum, aStr, arr
  Dim td$, tdUp$, tmp, bASC As Boolean
  Dim i&, n&, k0&, k1&, k2&, k3&
    Dim oListStr As Object
    Dim oListNum As Object
  Set oListStr = CreateObject("System.Collections.ArrayList")
  Set oListNum = CreateObject("System.Collections.ArrayList")
  arr = Array(-1, -1, -1, -1) ' Loi, Rong, So, Chuoi
  td = ChrW(273):       tdUp = ChrW(272)
  bASC = jCol > 0:      jCol = Abs(jCol)
  For n = fRow To eRow 'Dem cac loai du lieu
    tmp = sArr(aRow(n), jCol)
    If IsError(tmp) Then 'du lieu error
      arr(0) = arr(0) + 1
    ElseIf IsEmpty(tmp) Then 'du lieu Rong
      arr(1) = arr(1) + 1
    ElseIf IsNumeric(tmp) = True Then 'du lieu So
      arr(2) = arr(2) + 1
    Else 'du lieu Chuoi
      arr(3) = arr(3) + 1
    End If
  Next n
  If arr(0) >= 0 Then ReDim aErr(0 To arr(0))
  If arr(1) >= 0 Then ReDim aEmp(0 To arr(1))
  If arr(2) >= 0 Then ReDim aNum(0 To arr(2))
  If arr(3) >= 0 Then ReDim aStr(0 To arr(3))
  For n = fRow To eRow 'Gan cac loai du lieu vao mang tuong ung
    i = aRow(n)
    tmp = sArr(i, jCol)
    If IsError(tmp) Then
      k0 = k0 + 1:  aErr(k0 - 1) = i
    ElseIf IsEmpty(tmp) Then
      k1 = k1 + 1:  aEmp(k1 - 1) = i
    ElseIf IsNumeric(tmp) = True Then
      k2 = k2 + 1:  aNum(k2 - 1) = i
      oListNum.Add tmp
    Else
      If InStr(1, tmp, td, vbBinaryCompare) > 0 Then tmp = Replace(tmp, td, "dzz")
      If InStr(1, tmp, tdUp, vbBinaryCompare) > 0 Then tmp = Replace(tmp, tdUp, "Dzz")
      k3 = k3 + 1:  aStr(k3 - 1) = i
      oListStr.Add tmp
    End If
  Next n
  If k2 > 0 Then aNum = SortRow(oListNum, aNum, bASC) 'Sort du lieu So
  If k3 > 0 Then aStr = SortRow(oListStr, aStr, bASC) 'Sort du lieu Chuoi
  If bASC Then
    arr = Array(aNum, aStr, aErr, aEmp) ' So, Chuoi, Loi, Rong
  Else
    arr = Array(aStr, aNum, aErr, aEmp) ' Chuoi, So, Loi, Rong
  End If
  k1 = fRow - 1
  For n = 0 To 3
    If IsArray(arr(n)) Then
      For i = 0 To UBound(arr(n))
        k1 = k1 + 1
        aRow(k1) = arr(n)(i)
      Next i
    End If
  Next n
  Set oListNum = Nothing:   Set oListStr = Nothing
End Sub

Private Function SortRow(tList, aSort, bASC)
  Dim arr(), sR&, i&, k&, r&, tmp, tmp2, oList As Object

  On Error Resume Next
  ReDim arr(0 To UBound(aSort))
  Set oList = tList.Clone
  tList.Sort
  If bASC = False Then tList.Reverse
  For i = 0 To tList.Count - 1
    tmp = tList.Item(i)
    r = oList.IndexOf(tmp, 0)
    If tmp = tList.Item(i + 1) Then oList.Item(r) = Empty
      k = k + 1
      arr(k - 1) = aSort(r)
  Next i
  SortRow = arr
  Set oList = Nothing
End Function
 
Upvote 0
MyHanhCB said:
Thank you guys.
I have found a function, but using it on my machine is fine. When I switch to another machine, I get an error at
VBA Code:
Set oListStr = CreateObject("System.Collections.ArrayList")
Set oListNum = CreateObject("System.Collections.ArrayList"
VBA Code:
I'm using vb6.
VBA Code: 
Option Explicit
Function SortArray2D(ByVal sArr, ByVal aCol, Optional bHeader As Boolean = False) As Variant
  'Sort Mang 2 chieu "sArr" theo nhieu Cot
  'aCol: So hoac Mang so, so duong tu A => Z, so am tu Z => A
  'Ví du aCol:'          2:  Sort theo cot 2 tu A => Z
              '         -3:  Sort theo cot 3 tu Z => A
              'Array(2,-4): (VBA) Sort theo cot 2 tu A => Z và Sort theo cot 4 tu Z => A
              '{2,-4}:      (Cong thuc trong Sheet) Sort theo cot 2 tu A => Z và Sort theo cot 4 tu Z => A
  'bHead = True Du lieu co dong tieu de. Mac dinh bHead = False Du lieu khong co dong tieu de
  Dim aRow, Res()
  Dim uRow&, sRow&, fRow&, eRow&, fCol&, eCol&, jCol&, b&, i&, r&, n&, k&, j&, fr&
  Dim td$, tdUp$, bASC As Boolean, tmp, tmp2

  If TypeName(sArr) = "Range" Then sArr = sArr.Value
  If IsArray(sArr) = False Then Exit Function
  fRow = LBound(sArr, 1):   eRow = UBound(sArr, 1)
  fCol = LBound(sArr, 2):   eCol = UBound(sArr, 2)
  If IsArray(aCol) = False Then aCol = Array(aCol) 'Mang thu tu cot Sort
  If bHeader Then b = 1
  uRow = eRow - fRow - b
  ReDim aRow(0 - b To uRow) 'Mang thu tu dong du lieu goc
  For i = fRow To eRow
    aRow(i - fRow - b) = i
  Next i
  For n = LBound(aCol) To UBound(aCol)
    If n = LBound(aCol) Then 'Sort theo cot dau tien
      Call ChiaDuLieu(aRow, sArr, 0, uRow, aCol(n))
    Else 'Sort theo cac cot ke tiep
      fr = -1
      jCol = Abs(aCol(n - 1))
      For i = 0 To uRow - 1
        tmp = sArr(aRow(i), jCol): tmp2 = sArr(aRow(i + 1), jCol)
        If Not IsError(tmp) And Not IsError(tmp2) Then
          If fr >= 0 Then
            If tmp <> tmp2 Then
              Call ChiaDuLieu(aRow, sArr, fr, i, aCol(n))
              fr = -1
            ElseIf i = uRow - 1 Then
              Call ChiaDuLieu(aRow, sArr, fr, uRow, aCol(n))
              fr = -1
            End If
          ElseIf tmp = tmp2 Then
            fr = i
          End If
        End If
      Next i
    End If
  Next n

  k = fRow - 1
  ReDim Res(fRow To eRow, fCol To eCol) 'Mang ket qua
  For i = 0 - b To uRow
    k = k + 1
    r = aRow(i)
    For j = fCol To eCol
      Res(k, j) = sArr(r, j)
    Next j
  Next i
  SortArray2D = Res
End Function
Private Sub ChiaDuLieu(aRow, sArr, ByVal fRow&, ByVal eRow&, ByVal jCol&)
'  Dim oListStr As Object, oListNum As Object
  Dim aErr, aEmp, aNum, aStr, arr
  Dim td$, tdUp$, tmp, bASC As Boolean
  Dim i&, n&, k0&, k1&, k2&, k3&
    Dim oListStr As Object
    Dim oListNum As Object
  Set oListStr = CreateObject("System.Collections.ArrayList")
  Set oListNum = CreateObject("System.Collections.ArrayList")
  arr = Array(-1, -1, -1, -1) ' Loi, Rong, So, Chuoi
  td = ChrW(273):       tdUp = ChrW(272)
  bASC = jCol > 0:      jCol = Abs(jCol)
  For n = fRow To eRow 'Dem cac loai du lieu
    tmp = sArr(aRow(n), jCol)
    If IsError(tmp) Then 'du lieu error
      arr(0) = arr(0) + 1
    ElseIf IsEmpty(tmp) Then 'du lieu Rong
      arr(1) = arr(1) + 1
    ElseIf IsNumeric(tmp) = True Then 'du lieu So
      arr(2) = arr(2) + 1
    Else 'du lieu Chuoi
      arr(3) = arr(3) + 1
    End If
  Next n
  If arr(0) >= 0 Then ReDim aErr(0 To arr(0))
  If arr(1) >= 0 Then ReDim aEmp(0 To arr(1))
  If arr(2) >= 0 Then ReDim aNum(0 To arr(2))
  If arr(3) >= 0 Then ReDim aStr(0 To arr(3))
  For n = fRow To eRow 'Gan cac loai du lieu vao mang tuong ung
    i = aRow(n)
    tmp = sArr(i, jCol)
    If IsError(tmp) Then
      k0 = k0 + 1:  aErr(k0 - 1) = i
    ElseIf IsEmpty(tmp) Then
      k1 = k1 + 1:  aEmp(k1 - 1) = i
    ElseIf IsNumeric(tmp) = True Then
      k2 = k2 + 1:  aNum(k2 - 1) = i
      oListNum.Add tmp
    Else
      If InStr(1, tmp, td, vbBinaryCompare) > 0 Then tmp = Replace(tmp, td, "dzz")
      If InStr(1, tmp, tdUp, vbBinaryCompare) > 0 Then tmp = Replace(tmp, tdUp, "Dzz")
      k3 = k3 + 1:  aStr(k3 - 1) = i
      oListStr.Add tmp
    End If
  Next n
  If k2 > 0 Then aNum = SortRow(oListNum, aNum, bASC) 'Sort du lieu So
  If k3 > 0 Then aStr = SortRow(oListStr, aStr, bASC) 'Sort du lieu Chuoi
  If bASC Then
    arr = Array(aNum, aStr, aErr, aEmp) ' So, Chuoi, Loi, Rong
  Else
    arr = Array(aStr, aNum, aErr, aEmp) ' Chuoi, So, Loi, Rong
  End If
  k1 = fRow - 1
  For n = 0 To 3
    If IsArray(arr(n)) Then
      For i = 0 To UBound(arr(n))
        k1 = k1 + 1
        aRow(k1) = arr(n)(i)
      Next i
    End If
  Next n
  Set oListNum = Nothing:   Set oListStr = Nothing
End Sub

Private Function SortRow(tList, aSort, bASC)
  Dim arr(), sR&, i&, k&, r&, tmp, tmp2, oList As Object

  On Error Resume Next
  ReDim arr(0 To UBound(aSort))
  Set oList = tList.Clone
  tList.Sort
  If bASC = False Then tList.Reverse
  For i = 0 To tList.Count - 1
    tmp = tList.Item(i)
    r = oList.IndexOf(tmp, 0)
    If tmp = tList.Item(i + 1) Then oList.Item(r) = Empty
      k = k + 1
      arr(k - 1) = aSort(r)
  Next i
  SortRow = arr
  Set oList = Nothing
End Function
Click to expand...
Specifically, the error message is as follows.
 

Attachments

  • anhg.jpg
    anhg.jpg
    9.9 KB · Views: 10
Upvote 0
VBA Code: 
Sub test()
  Dim myArr As Variant
  myArr = [{"A", 3; "B", 2; "C", 5; "D", 1; "E", 4}]
  myArr = sort2ndDimension(myArr, "desc")
  'You may delete this part. Only for display purposes
  For r = LBound(myArr, 1) To UBound(myArr, 1)
    For c = LBound(myArr, 2) To UBound(myArr, 2)
      Debug.Print myArr(r, c)
    Next
  Next
End Sub

Function sort2ndDimension(ByRef mySort As Variant, ByVal orderBy As String) As Variant()
  Dim temp(1) As Variant
  Select Case orderBy
  Case "desc"
  For i = LBound(mySort, 1) To UBound(mySort, 1) - 1
    For j = i + 1 To UBound(mySort, 1)
      If mySort(j, 2) > mySort(i, 2) Then
        For k = LBound(mySort, 2) To UBound(mySort, 2)
          temp(k - 1) = mySort(i, k)
          mySort(i, k) = mySort(j, k)
          mySort(j, k) = temp(k - 1)
        Next
      End If
    Next
  Next
  Case "asc"
  For i = LBound(mySort) To UBound(mySort) - 1
    For j = i + 1 To UBound(mySort)
      If mySort(j, 2) < mySort(i, 2) Then
        For k = 1 To 2
          temp(k - 1) = mySort(i, k)
          mySort(i, k) = mySort(j, k)
          mySort(j, k) = temp(k - 1)
        Next
      End If
    Next
  Next
  End Select
  sort2ndDimension = mySort
End Function
 
Upvote 1
Solution
Flashbond said:
VBA Code: 
Sub test()
  Dim myArr As Variant
  myArr = [{"A", 3; "B", 2; "C", 5; "D", 1; "E", 4}]
  myArr = sort2ndDimension(myArr, "desc")
  'You may delete this part. Only for display purposes
  For r = LBound(myArr, 1) To UBound(myArr, 1)
    For c = LBound(myArr, 2) To UBound(myArr, 2)
      Debug.Print myArr(r, c)
    Next
  Next
End Sub

Function sort2ndDimension(ByRef mySort As Variant, ByVal orderBy As String) As Variant()
  Dim temp(1) As Variant
  Select Case orderBy
  Case "desc"
  For i = LBound(mySort, 1) To UBound(mySort, 1) - 1
    For j = i + 1 To UBound(mySort, 1)
      If mySort(j, 2) > mySort(i, 2) Then
        For k = LBound(mySort, 2) To UBound(mySort, 2)
          temp(k - 1) = mySort(i, k)
          mySort(i, k) = mySort(j, k)
          mySort(j, k) = temp(k - 1)
        Next
      End If
    Next
  Next
  Case "asc"
  For i = LBound(mySort) To UBound(mySort) - 1
    For j = i + 1 To UBound(mySort)
      If mySort(j, 2) < mySort(i, 2) Then
        For k = 1 To 2
          temp(k - 1) = mySort(i, k)
          mySort(i, k) = mySort(j, k)
          mySort(j, k) = temp(k - 1)
        Next
      End If
    Next
  Next
  End Select
  sort2ndDimension = mySort
End Function
Click to expand...
yep. thanks bro
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
"Subscript out of range ( Run time Error: 09)" Problem in My Excel VBA
Replies
5
Views
277
6StringJazzer
6StringJazzer
JeffGrant
  • Solved
Array output - very very strange - I am a complete loss
Replies
4
Views
342
Peter_SSs
Peter_SSs
I
  • Question
Listbox not being populate when code is run
Replies
4
Views
302
ipbr21054
I
S
  • Solved
Display data of Specific Sheets on Listbox Userform
2
Replies
11
Views
875
Akuini
Akuini
MyHanhCB
  • Question
Editing the lookup function for each argument.
Replies
4
Views
182
MyHanhCB
MyHanhCB

Forum statistics

Threads
1,215,214
Messages
6,123,664
Members
449,114
Latest member
aides

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