Az oszlopok sorrendjét többféleképpen lehet módosítani:
1. Manuálisan: Kivágás – Kivágott cellák beszúrása. Pl. az “E” oszlopot szeretném az “A” elé tenni:
Megjegyzés: nem kell külön kijelölni az oszlopot (bal klikkel), mehet egyből a jobb klikk az oszlop nevén.
2. Manuálisan: a kevésbé ismert SHIFT + vontatásos módszer. Itt is az “E” oszlopot szeretném az “A” elé tenni:
“E” oszlop kijelölése: kurzort a kijelölt oszlop szélére vinni (kurzor célkeresztre változik) -> SHIFT-et lenyomva tartani -> bal egérgombot lenyomni és az egeret balra húzni -> megfelelő helyen egeret, majd a SHIFT-et elengedni. Kép/animáció formájában:
“E” oszlop kijelölése, egérkurzort a kijelölt oszlop szélésre vinni (célkereszt):
SHIFT-et lenyomva tartani -> bal egérgombot lenyomni és az egeret balra húzni (a vastag függőleges zöld vonal mutatja az oszlop új helyét):
Ez az utóbbi módszer nyakatekertnek tűnik, de ha megszokjuk, jóval könnyebben és gyorsabban tudunk áthelyezni oszlopokat.
De mi van akkor, ha több oszlopot akarunk adott sorrendbe rakni? A fenti példát picit nehezítsük: az oszlopok sorrendben vannak…
… de én ezt az új sorrendet akarom:
Ezt már beletelne pár másodpercbe átrendezni, persze lehetne több tucat vagy akár több száz oszlop is.
Megoldások a fenti sorrend módosítására makrók formájában:
3. Oszlopok sorba rendezése a ‘HeaderFinal’ nevű tömb alapján: kivágás-beillesztéssel
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
Sub ColumnRearrange_01() Dim HeaderFinal(), i As Long, Cella As Range 'oszlopok sorba rendezése a 'HeaderFinal' alapján: kivágás-beillesztéssel 'futási idő: kb. 0.0547 sec. 'ideális ha minden oszlopot sorba akarunk rendezni (vagyis az oszlopok nevei ugyanazok, mint a 'HeaderFinal' tömbben). 'A tömbben NEM lévő oszlopokat bent hagyja az elején. Application.ScreenUpdating = False HeaderFinal = Array("Oszlop2", "Oszlop4", "Oszlop3", "Oszlop1", "Oszlop5") 'alapállapot visszaállítása: Worksheets("Original").Cells.Copy Worksheets("Sheet1").Cells(1, 1) Worksheets("Sheet1").Select For i = LBound(HeaderFinal) To UBound(HeaderFinal) For Each Cella In Worksheets("Sheet1").UsedRange.Rows(1).Cells If HeaderFinal(i) = Cella.Value Then Cella.EntireColumn.Cut Columns(Worksheets("Sheet1").UsedRange.Columns.Count + 1).Insert Exit For End If Next Cella Next i Application.ScreenUpdating = True End Sub |
4. Oszlopok sorba rendezése a ‘HeaderFinal’ nevű tömb alapján: index + sorbarendezéssel
Érdekesség, hogy itt a kevésbé ismert oszloprendezést alkalmazzuk, mely Excelben manuálisan így néz ki (aktív cella legyen a tartományon belül):
A kód, mely az iménti rendezést használja:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
Sub ColumnRearrange_02() Dim HeaderFinal(), i As Long, Cella As Range, SortRange As Range 'oszlopok sorba rendezése a 'HeaderFinal' alapján: index + sorbarendezéssel 'futási idő: kb. 0.0344 sec. 'ideális ha minden oszlopot sorba akarunk rendezni (vagyis az oszlopok nevei ugyanazok, mint a 'HeaderFinal' tömbben). 'A tömbben NEM lévő oszlopokat bent hagyja a végén. Application.ScreenUpdating = False HeaderFinal = Array("Oszlop2", "Oszlop4", "Oszlop3", "Oszlop1", "Oszlop5") 'alapállapot visszaállítása: Worksheets("Original").Cells.Copy Worksheets("Sheet1").Cells(1, 1) Worksheets("Sheet1").Select Rows("1:1").Insert shift:=xlDown Cells(1, 1).Value = "Bla" 'hogy az 1. sor is benne legyen a usedrange-ben For i = LBound(HeaderFinal) To UBound(HeaderFinal) For Each Cella In Worksheets("Sheet1").UsedRange.Rows(2).Cells If HeaderFinal(i) = Cella.Value Then Cella.Offset(-1, 0).Value = i + 1 End If Next Cella Next i 'oszlopok rendezése az 1. sorban lévő indexszámok alapján: Set SortRange = Worksheets("Sheet1").UsedRange Worksheets("Sheet1").Sort.SortFields.Clear SortRange.Sort key1:=Range(SortRange.Rows(1).Address), order1:=xlAscending, Orientation:=xlLeftToRight '1. sor törlése: Rows("1:1").Delete shift:=xlUp Application.ScreenUpdating = True End Sub |
5. Oszlopok sorba rendezése Irányított Szűréssel
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
Sub ColumnRearrange_03() Dim HeaderFinal(), i As Long 'oszlopok sorba rendezése Irányított Szűréssel 'futási idő: kb. 0.0156 'akkor is ideális, ha NEM minden oszlop neve szerepel a 'HeaderFinal' tömbben. 'CSAK a 'HeaderFinal' tömbben lévő oszlopokat jeleníti meg. Application.ScreenUpdating = False HeaderFinal = Array("Oszlop2", "Oszlop4", "Oszlop3", "Oszlop1", "Oszlop5") 'alapállapot visszaállítása: With Worksheets("Sheet1") .Cells.Clear .Cells(1, 1).Resize(, UBound(HeaderFinal) + 1) = HeaderFinal .Select End With 'Irányított Szűrés: 'Sheets("Original").Range("A1:E20").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("A1:E1"), Unique:=False Worksheets("Original").UsedRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Worksheets("Sheet1").UsedRange.Rows(1), Unique:=False Application.ScreenUpdating = True End Sub |
Az utolsó 3 (makrós) változatnál egyébként a legutolsó metódus a leggyorsabb.
A fájl letölthető innen.
További szép napot, egészséget és kitartást ebben a rekkenő hőségben.
