Microsoft Excel & VBA

Určitě jste se už setkali během Vaši práce s VBA s potřebou seřadit předané položky v polích.
V podstatě máme tyto možnosti;

• zapsat data z pole na list, seřadit je a nahrát zpět do pole
tzv. Worksheet - sort metoda
• použít Bubble-sort - metoda řazení ve VBA (použitelná do 5 000 položek)
• použít Quick-sort - metoda řazení ve VBA (velice rychlá)
• použít Counting-sort - metoda řazení ve VBA (extrémně rychlá)

S největší pravděpodobnosti jsme jednoduše použili jednu z těchto metod a pokračovali dále v psaní kódu, ale co dělat, když budete stát před úkolem, jak seřadit data v jedno nebo dvou rozměrných polích podle uživatelského seznamu? Většina z nás použije první možnost z nabízeného seznamu typů řazení a tedy vloží data z pole na list, nahraje si do uživatelských seznamů svůj aktuálně používaný seznam a nechá data seřadit podobném příkazem víz. níže Office 2007

ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add
        Key:=Range("A1:A8"), _
        SortOn:=xlSortOnValues, _
        Order:=xlAscending, _
        CustomOrder:="Po,Út,St,Čt,Pá,So,Ne", _
        DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
    .SetRange Range("A1:C8")
    .Header = xlGuess
    .MatchCase = False
    .Apply
End With

Office 2003 a nižší

Selection.Sort Key1:=Range("A1"), _
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=2, MatchCase:=False

Jaké jsou nevýhody tohoto řešení?

1, převod dat z pole na list a pak zpět do pole

2, v nižších verzích, musíte nejprve kódem zajistit nahrání Vašeho seznamu do Excelu zjištěni jeho pořadového čísla a poté toto číslo použit v argumentu OrderCustom:=

Ve verzi 2007 můžete použit přímo pole s uživatelským pořadím.
Dim arrCustomOrder As String
arrCustomOrder = "zluta,cervena,zelena,modra,hneda,cerna"

ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add       Key:=Range("A1:A8"), _
      SortOn:=xlSortOnValues, _
      Order:=xlAscending, _
      CustomOrder:=CStr(arrCustomOrder), _
      DataOption:=xlSortNormal

3, Nelze řadit podle čísel

Možná se Vám toto řešení problému nelíbí tak jako mě a protože jsem stál před problémem jak řadit 2D pole podle uživatelského seznamu, rozhodl jsem se napsat kód, který toto řeší.
Pro správnou funkci je zapotřebí následující

a, Hlavní pole - arrMain - které obsahuje neseřazené položky
b, Uživatelské pole - arrCustomOrder - které obsahuje uživatelský seznam
 řazení
c, pomocné pole pro řazení - arrTemp - které bude obsahovat seřazené pole

1, pro řazení podle uživatelského seznamu jsem musel použit metodu bubble-sort
    - tedy tu nejpomalejší - protože nelze rozdělit položky na menší a větší a
    na těch provést seřazení jako to dělá metoda Quick-sort.

2, jelikož pole dat může obsahovat více položek než je v uživatelském seznamu,
    musím zjišťovat jestli všechny záznamy byly seřazeny a pokud ne, procházím pole
    dat položku po položce a kontroluji jestli je obsažena v poli uživatelského seznamu.
Pokud aktuální položka není obsažena v tomto seznamu, bude přeřazena nakonec
pomocného pole.

3, na konci řazení jsou seřazené data uložená v pomocném poli - arrTemp. Vzhledem
    k tomu, že jsem nechtěl použít API funkce - CopyMemory, rozhodl jsem pro
    klasické překlopení pomocného pole do hlavního pole pomocí cyklu For - Next.

Výhody tohoto řešení

1, použitelné na všech dostupných verzích Office
2, není třeba data přenášet na list a zpět
3, v nižších verzích Office (2003 a nižší) nemusíte přidávat data do
    uživatelského seznamu, zjišťovat číslo a pak seznam zase mazat.
4, řadí podle čísel (odzkoušeny čísla s dvěmi desetinými místy)
5, poměrně rychle řešení pro položky do 5 000 položek

Nevýhody

1, nad 5 000 položek může zpomalovat celý kód.

A teď onen slibovaný kód vč. testovací rutiny.

Všimněte si, že položka barvy "oranžová", kterou obsahuje hlavní pole, tedy neseřazené, není obsažená v uživatelském řazení a proto bude tato barva vždy řazena nakonci seřazeného pole.
Sub TestArray_2D_CustomSort()

Dim arrMain(1 To 7, 1 To 3) As Variant ' obsahuje neserazene data
Dim arrCustomOrder(1 To 6) As Variant ' uzivatelské pole
Dim byteColumnSort As Byte ' urcuje index pole, podle ktereho se radi

' vlozeni ukazkovych dat do pole s neserazenymi daty
arrMain(1, 1) = "blue" ' EN
arrMain(1, 2) = "blau" ' DE
arrMain(1, 3) = "modra" ' CZ

arrMain(2, 1) = "black" 'EN
arrMain(2, 2) = "schwarz" ' DE
arrMain(2, 3) = "cerna" ' CZ

arrMain(3, 1) = "orange" 'EN
arrMain(3, 2) = "orange" ' DE
arrMain(3, 3) = "oranzova" ' CZ

arrMain(4, 1) = "yellow" 'EN
arrMain(4, 2) = "gelb" ' DE
arrMain(4, 3) = "zluta" ' CZ

arrMain(5, 1) = "green" 'EN
arrMain(5, 2) = "grune" ' DE
arrMain(5, 3) = "zelena" ' CZ

arrMain(6, 1) = "brown" 'EN
arrMain(6, 2) = "braune" ' DE
arrMain(6, 3) = "hneda" ' CZ

arrMain(7, 1) = "red" ' EN
arrMain(7, 2) = "rot" ' DE
arrMain(7, 3) = "cervena" ' CZ

' vlozeni dat do pole - Custom Order (od nejsvetlejsi k nejtmavsi)
' pro priklad zvoleno Ceske razeni
arrCustomOrder(1) = "zluta"
arrCustomOrder(2) = "cervena"
arrCustomOrder(3) = "zelena"
arrCustomOrder(4) = "modra"
arrCustomOrder(5) = "hneda"
arrCustomOrder(6) = "cerna"
' EN (nezapomente zmenit hodnotu byteColumnSort =1 !)
' arrCustomOrder(1) = "yellow"
' arrCustomOrder(2) = "red"
' arrCustomOrder(3) = "green"
' arrCustomOrder(4) = "blue"
' arrCustomOrder(5) = "brown"
' arrCustomOrder(6) = "black"
' DE (nezapomente zmenit hodnotu byteColumnSort =2 !)
' arrCustomOrder(1) = "gelb"
' arrCustomOrder(2) = "rot"
' arrCustomOrder(3) = "grune"
' arrCustomOrder(4) = "blau"
' arrCustomOrder(5) = "braune"
' arrCustomOrder(6) = "schwarz"


' radit podle indexu pole arrMain (zde CESKY )
byteColumnSort = 3

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' PRO KONTROLU !
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
On Error Resume Next '
  Application.DisplayAlerts = False '
  Sheets("Check and delete").Delete '
  Application.DisplayAlerts = True '
On Error GoTo 0 '
'
  Sheets.Add '
  ActiveSheet.Name = "Check and delete" '
  Cells(1, 1) = "Neserazene pole" '
  Cells(1, 2) = "Serazene pole dle uzivatelskeho seznamu" '
  Cells(1, 3) = "Uzivatelsky seznam" '
  Columns("A:C").AutoFit '

For i = LBound(arrMain, 1) To UBound(arrMain, 1) '
  Cells(i + 1, 1) = arrMain(i, byteColumnSort) '
Next i '
' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

' Zavola funkci pro razeni 2D pole
If Array_2D_CustomSort(arrMain, arrCustomOrder,   byteColumnSort) Then

   Sheets("Check and delete").Activate

   For i = LBound(arrMain, 1) To UBound(arrMain, 1)
     Cells(i + 1, 2) = arrMain(i, byteColumnSort)
   Next i

   For i = LBound(arrCustomOrder) To   UBound(arrCustomOrder)
     Cells(i + 1, 3) = arrCustomOrder(i)
   Next i
   MsgBox "Konec"

Else
   MsgBox "Chyba"
End If

End Sub

Function Array_2D_CustomSort(arrMain() As Variant, arrCustomOrder() As Variant, byteColumnSort As Byte) As Boolean
' Tento priklad pouziva 2D pole
' 1, Neserazene pole (arrMain)
' 2, Uzivatelske pole (arrCustomOrder)
' 3, Cislo rozmeru neserazeneho pole pro setrizeni (byteColumnSort)
' pouziva bubble-sort metodu
' verze: 1.0 28.9.2007 Autor: Premysl Lazecky

Dim arrTemp() As Variant ' pomocne pole k serazeni
Dim i As Integer, j As Integer, k As Integer
Dim intNextWriteposition As Integer ' uchovava posledni hodnotu pro zapis
Dim bolContain As Boolean

On Error GoTo errtitle

' Predimenzovani pole
ReDim arrTemp(LBound(arrMain, 1) To UBound(arrMain, 1), LBound(arrMain, 2) To UBound(arrMain, 2))

' razeni podle uzivatelskeho seznamu
For i = LBound(arrCustomOrder) To UBound(arrCustomOrder)
  For j = LBound(arrMain, 1) To UBound(arrMain, 1)
' kdyz hodnota v hlavnim poli (v rozmeru ktery je zadan - byteColumnSort
' odpovida uzivatelskemu seznamu, je hodnota presunuta do prvniho
' volneho indexu pomocneho pole
    If arrMain(j, byteColumnSort) = arrCustomOrder(i) Then
' udrzuje posledni volny index pomocneho pole
      intNextWriteposition = intNextWriteposition + 1
' prepise vsechny data do pomocneho pole
      For k = LBound(arrTemp, 2) To UBound(arrTemp, 2)
          arrTemp(intNextWriteposition, k) = arrMain(j, k)
      Next k
    End If
  Next j
Next i

' Zkontroluje zda pole Temp ma stejny pocet polozek jako hlavni pole
' Protoze nektere polozky, ktere obsahuje Hlavni pole nemuseji odpovidat
' polozkam v uzivatelskem razeni, vsechny tyto polozky budou presunuty na
' konec pole arrTemp
If intNextWriteposition < UBound(arrMain, 1) Then
   For i = LBound(arrMain) To UBound(arrMain)
bolContain = False
      For j = LBound(arrCustomOrder, 1) To UBound(arrCustomOrder, 1)
        If arrMain(i, byteColumnSort) = arrCustomOrder(j) Then
           bolContain = True
           Exit For
        End If
      Next j
' pokud promenna "bolContain" = False, bude polozka presunuta na
' posledni volny index pole arrTemp"
      If Not bolContain Then
         intNextWriteposition = intNextWriteposition + 1
         For k = LBound(arrTemp, 2) To UBound(arrTemp, 2)
         arrTemp(intNextWriteposition, k) = arrMain(i, k)
         Next k
      End If
   Next i
End If

' kopiruje pomocne pole do hlavniho pole
' nechtel jsem pouzit API funkce
For j = LBound(arrMain, 1) To UBound(arrMain, 1)
  For k = LBound(arrTemp, 2) To UBound(arrTemp, 2)
     arrMain(j, k) = arrTemp(j, k)
  Next k
Next j

Erase arrTemp
Array_2D_CustomSort = True
Exit Function

errtitle:
Array_2D_CustomSort = False
Erase arrTemp

End Function