locked
Excel VBA - Sort an array RRS feed

  • Question

  • Hi Everyone

    I need a hand writing a piece of code to sort an array in VBA

    My array will look like this (please not this a VBA populated array not an excel worksheet)

      display Active filter Order value
    Account Y Y 3 500
    Customer N N - -
    Portfolio Y N 1 -
    Currency Y Y 2 USD

    Each field the user has chosen to display is assigned a numerical value identifying in which order he whishes to see the data.
    This will then be fed in a dynamic SQL code (the main purpose of my spreadsheet)
    What I am struggling to do  is to extract the relevant data using the order values.
    i.e. Extract Portfolio fields 1st, then Currency fields, then account fiels and ignore Customer.

    If anyone has a solution, you would be a life saver!

    Thanks

    • Moved by Reed KimbleMVP Tuesday, September 29, 2009 3:17 PM VBA in VB Language (From:Visual Basic Language)
    Monday, September 28, 2009 9:54 AM

Answers

  • I would make a Type to hold each row's values. Then use quicksort to sort them. See:

        http://www.vb-helper.com/howto_quicksort.html

    You could use several arrays to hold each column's values but that makes rearranging them harder.

    Rod

    Rod Stephens, Visual Basic MVP

    Visual Basic 2008 Programmer's Reference
    http://www.amazon.com/exec/obidos/ASIN/0470182628/vbhelper/
    • Marked as answer by Tim Li Monday, October 5, 2009 5:49 AM
    Monday, September 28, 2009 1:51 PM

All replies

  • I would make a Type to hold each row's values. Then use quicksort to sort them. See:

        http://www.vb-helper.com/howto_quicksort.html

    You could use several arrays to hold each column's values but that makes rearranging them harder.

    Rod

    Rod Stephens, Visual Basic MVP

    Visual Basic 2008 Programmer's Reference
    http://www.amazon.com/exec/obidos/ASIN/0470182628/vbhelper/
    • Marked as answer by Tim Li Monday, October 5, 2009 5:49 AM
    Monday, September 28, 2009 1:51 PM
  • If Rod suggestions does not help, you may consider post the question in VBA forum http://social.msdn.microsoft.com/forums/en-US/isvvba/threads/

    kaymaf
    I hope this helps, if that is what you want, just mark it as answer so that we can move on
    Monday, September 28, 2009 7:58 PM
  • Helo, This maybe what you want. http://zenhileon.blog.163.com/blog/static/13841737820109981048195/ or Option Explicit Option Compare Text Type tagSortSpecialParameter SortSequence(0 To 2) As Long 'Sort field ,如果只想用1个或2个字段排序的话,其它的值设为-1 SortType(0 To 2) As Long '0: Asending other: desending SortMethod(0 To 2) As Long 'Reserved, for modification End Type Public Sub sSortSpecial(DataTt As Variant, SortSPara As tagSortSpecialParameter) Dim i As Long, j As Long, k As Long, temp As Variant, tempD As Long, tempD1 As Long Dim arrayD() As Long Dim arrayD0() As Long, m As Long, x As Long, y As Long Dim arrayD1() As Long, mm As Long, xx As Long, yy As Long Dim ii As Integer, jj As Integer, kk As Integer Dim iub2 As Long, lb2 As Long, ub2 As Long, lb As Long, ub As Long Dim L As Long, ArrayTemp() As Variant Dim Mark() As Long, Mark2() As Long, SortBoolean As Boolean lb = LBound(DataTt): ub = UBound(DataTt) lb2 = LBound(DataTt, 2): ub2 = UBound(DataTt, 2) ReDim Mark(lb To ub) ReDim arrayD0(lb To ub) ReDim ArrayTemp(lb2 To ub2) Dim DataTt1 As Variant ReDim DataTt1(lb To ub, lb2 To ub2) '对其进行赋值 For i = lb To ub arrayD0(i) = i 'Data原来的顺序,Lb----ub For j = lb2 To ub2 DataTt1(i, j) = DataTt(i, j) ''''''可用CopyMemory 一下子拷贝 Next j Next i With SortSPara '判断排序的相关段是否合要求 '第一步: 对数据进行排序,得到排序的数组的序号 For i = lb To ub For j = i + 1 To ub If .SortType(0) Then SortBoolean = DataTt1(arrayD0(i), .SortSequence(0)) < DataTt1(arrayD0(j), .SortSequence(0)) 'Asending Else SortBoolean = DataTt1(arrayD0(i), .SortSequence(0)) > DataTt1(arrayD0(j), .SortSequence(0)) 'Desending End If If SortBoolean Then '不要相互交换,而要向下移 '提出数据 tempD = arrayD0(j) '向下移 For L = j To i + 1 Step -1 tempD1 = arrayD0(L) arrayD0(L) = arrayD0(L - 1) arrayD0(L - 1) = tempD1 Next L '写入数据 arrayD0(i) = tempD End If Next j Mark(i) = 0 Next i '第二步:从DataTt1(ub,ub2)找到.SortSequence(0)相同的数值的序号存入arryaD() 'GoTo ExitSort If .SortSequence(1) < lb2 Then GoTo ExitSort k = 0 m = 0 For i = lb To ub temp = DataTt1(arrayD0(i), .SortSequence(0)) Mark(i) = 1 For j = i + 1 To ub If DataTt1(arrayD0(j), .SortSequence(0)) = temp Then k = k + 1 m = m + 1 Mark(j) = 1 ReDim Preserve arrayD(m) If k = 1 Then arrayD(0) = arrayD0(i) End If arrayD(m) = arrayD0(j) End If Next j '第三步:对序号arryaD()对应的数据进行 .SortSequence(1)排序 ReDim Mark2(m) If m > 0 Then For x = 0 To m Mark2(x) = 0 For y = x + 1 To m If .SortType(1) Then SortBoolean = DataTt1(arrayD(x), .SortSequence(1)) < DataTt1(arrayD(y), .SortSequence(1)) 'Asending Else SortBoolean = DataTt1(arrayD(x), .SortSequence(1)) > DataTt1(arrayD(y), .SortSequence(1)) 'Desending End If If SortBoolean Then '不要相互交换,而要向下移 tempD = arrayD(y) '向下移 For L = y To x + 1 Step -1 tempD1 = arrayD(L) arrayD(L) = arrayD(L - 1) arrayD(L - 1) = tempD1 Next L '写入 arrayD(x) = tempD End If Next y Next x For L = 0 To m arrayD0(i + L) = arrayD(L) Next L 'GoTo ExitSort1 '第四步: 从序号arryaD()对应的数据找到.SortSequence(1)相同的数值的序号存入arryaD1() ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' If .SortSequence(2) < lb2 Then GoTo ExitSort1 kk = 0 mm = 0 For x = 0 To m temp = DataTt1(arrayD(x), .SortSequence(1)) Mark2(x) = 1 For y = x + 1 To m If DataTt1(arrayD(y), .SortSequence(1)) = temp Then kk = kk + 1 mm = mm + 1 ReDim Preserve arrayD1(mm) Mark2(y) = 1 If kk = 1 Then arrayD1(0) = arrayD(x) End If arrayD1(mm) = arrayD(y) End If Next y '第五步:对序号arryaD1()对应的数据进行 .SortSequence(2)排序 If mm > 0 Then For xx = 0 To mm For yy = xx + 1 To mm If .SortType(2) Then SortBoolean = DataTt1(arrayD1(xx), .SortSequence(2)) < DataTt1(arrayD1(yy), .SortSequence(2)) 'Asending Else SortBoolean = DataTt1(arrayD1(xx), .SortSequence(2)) > DataTt1(arrayD1(yy), .SortSequence(2)) 'Desending End If If SortBoolean Then '不要相互交换,而要向下移 '提出数据 tempD = arrayD1(yy) '向下移 For L = yy To xx + 1 Step -1 tempD1 = arrayD0(L) arrayD1(L) = arrayD1(L - 1) arrayD1(L - 1) = tempD1 Next L '写入 arrayD1(xx) = tempD End If Next yy Next xx For L = 0 To mm arrayD0(i + x + L) = arrayD1(L) Next L x = getMark(Mark2) - 1 kk = 0 mm = 0 End If Next x '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ExitSort1: i = getMark(Mark) - 1 k = 0 m = 0 End If Next i End With '整理数据 ExitSort: For i = lb To ub For j = lb2 To ub2 DataTt(i, j) = DataTt1(arrayD0(i), j) Next j Next i Erase arrayD Erase arrayD0 Erase arrayD1 Erase ArrayTemp Erase Mark Erase Mark2 Erase DataTt1 End Sub Public Sub sSortSpecial1(DataTt As Variant, SortSPara As tagSortSpecialParameter) Dim i As Long, j As Long, k As Long, temp As Variant, temp1 As Variant, tempD As Long, tempD1 As Long Dim arrayD() As Long Dim arrayD0() As Long, m As Long, x As Long, y As Long Dim arrayD1() As Long, mm As Long, xx As Long, yy As Long Dim ii As Integer, jj As Integer, kk As Integer Dim iub2 As Long, lb2 As Long, ub2 As Long, lb As Long, ub As Long Dim L As Long, ArrayTemp() As Variant Dim Mark() As Long, SortBoolean As Boolean Dim DataTt1 As Variant lb = LBound(DataTt): ub = UBound(DataTt) lb2 = LBound(DataTt, 2): ub2 = UBound(DataTt, 2) ReDim Mark(lb To ub) ReDim arrayD0(lb To ub) ReDim ArrayTemp(lb2 To ub2) '对其进行赋值 ReDim DataTt1(lb To ub, lb2 To ub2) '对其进行赋值 For i = lb To ub arrayD0(i) = i For j = lb2 To ub2 DataTt1(i, j) = DataTt(i, j) Next j Next i With SortSPara '判断排序的相关段是否合要求 '第一步: 对数据进行排序,得到排序的数组的序号 For i = lb To ub For j = i + 1 To ub If .SortType(0) Then SortBoolean = DataTt1(arrayD0(i), .SortSequence(0)) < DataTt1(arrayD0(j), .SortSequence(0)) 'Asending Else SortBoolean = DataTt1(arrayD0(i), .SortSequence(0)) > DataTt1(arrayD0(j), .SortSequence(0)) 'Desending End If If SortBoolean Then '不要相互交换,而要向下移 '提出数据 tempD = arrayD0(j) '向下移 For L = j To i + 1 Step -1 tempD1 = arrayD0(L) arrayD0(L) = arrayD0(L - 1) arrayD0(L - 1) = tempD1 Next L '写入数据 arrayD0(i) = tempD End If Next j Mark(i) = 0 Next i '第二级排序 '从DataTt1(ub,ub2)找到.SortSequence(0)相同的数值的序号存入arryaD() k = 0 m = 0 For i = lb To ub temp = DataTt1(arrayD0(i), .SortSequence(0)) Mark(i) = 1 For j = i + 1 To ub If DataTt1(arrayD0(j), .SortSequence(0)) = temp Then k = k + 1 m = m + 1 Mark(j) = 1 ReDim Preserve arrayD(m) If k = 1 Then arrayD(0) = arrayD0(i) End If arrayD(m) = arrayD0(j) End If Next j '对序号arryaD()对应的数据进行 .SortSequence(1)排序 If m > 0 Then For x = 0 To m For y = x + 1 To m If .SortType(0) Then SortBoolean = DataTt1(arrayD(x), .SortSequence(1)) < DataTt1(arrayD(y), .SortSequence(1)) 'Asending Else SortBoolean = DataTt1(arrayD(x), .SortSequence(1)) > DataTt1(arrayD(y), .SortSequence(1)) 'Desending End If If SortBoolean Then '不要相互交换,而要向下移 tempD = arrayD(y) '向下移 For L = y To x + 1 Step -1 tempD1 = arrayD(L) arrayD(L) = arrayD(L - 1) arrayD(L - 1) = tempD1 Next L '写入 arrayD(x) = tempD End If Next y Next x For L = 0 To m arrayD0(i + L) = arrayD(L) Next L i = getMark(Mark) - 1 k = 0 m = 0 End If Next i 'GoTo ExitSort If .SortSequence(2) < lb2 Then GoTo ExitSort '第三级排序 '从DataTt1(ub,ub2)找到.SortSequence(0) .SortSequence(1)相同的数值的序号存入arryaD() k = 0 m = 0 For i = lb To ub Mark(i) = 0 Next i For i = lb To ub temp = DataTt1(arrayD0(i), .SortSequence(0)) temp1 = DataTt1(arrayD0(i), .SortSequence(1)) Mark(i) = 1 For j = i + 1 To ub If (DataTt1(arrayD0(j), .SortSequence(0)) = temp) And (DataTt1(arrayD0(j), .SortSequence(1)) = temp1) Then k = k + 1 m = m + 1 Mark(j) = 1 ReDim Preserve arrayD(m) If k = 1 Then arrayD(0) = arrayD0(i) End If arrayD(m) = arrayD0(j) End If Next j '对序号arryaD()对应的数据进行 .SortSequence(2)排序 If m > 0 Then For x = 0 To m For y = x + 1 To m If .SortType(0) Then SortBoolean = DataTt1(arrayD(x), .SortSequence(2)) < DataTt1(arrayD(y), .SortSequence(2)) 'Asending Else SortBoolean = DataTt1(arrayD(x), .SortSequence(2)) > DataTt1(arrayD(y), .SortSequence(2)) 'Desending End If If SortBoolean Then '不要相互交换,而要向下移 tempD = arrayD(y) '向下移 For L = y To x + 1 Step -1 tempD1 = arrayD(L) arrayD(L) = arrayD(L - 1) arrayD(L - 1) = tempD1 Next L '写入 arrayD(x) = tempD End If Next y Next x For L = 0 To m arrayD0(i + L) = arrayD(L) Next L i = getMark(Mark) - 1 k = 0 m = 0 End If Next i End With ExitSort: For i = lb To ub For j = lb2 To ub2 DataTt(i, j) = DataTt1(arrayD0(i), j) Next j Next i Erase DataTt1 Erase arrayD Erase arrayD0 Erase arrayD1 Erase ArrayTemp Erase Mark End Sub
    Friday, June 17, 2011 2:00 PM