Sortering af mange rækker

Prøv denne:

Sub Makro1()
Dim MitArray, S As Long, I As Long, Y As Long, Temp
SlutR = Range("A1").SpecialCells(xlLastCell).Row
SlutC = Range("A1").SpecialCells(xlLastCell).Column
MitArray = Range(Cells(1, 1), Cells(SlutR, SlutC))

For S = 1 To UBound(MitArray)
    For I = 1 To UBound(MitArray, 2) - 1
        For Y = I To UBound(MitArray, 2)
            If MitArray(S, Y) > MitArray(S, I) Then
                Temp = MitArray(S, Y)
                MitArray(S, Y) = MitArray(S, I)
                MitArray(S, I) = Temp
            End If
        Next
    Next
Next
Range(Cells(1, 1), Cells(SlutR, SlutC)) = MitArray

End Sub

eller denne:

Sub Overordnetsortering()
Dim ræk
    ræk = 7
 
  Do
    Range("B" + CStr(ræk) & ":F" & CStr(ræk)).Select
    Selection.Sort Key1:=ActiveCell, Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, _
        DataOption1:=xlSortNormal
    ræk = ræk + 1
  Loop Until ActiveCell.Value = ""
End Sub

Jeg har prøvet begge 2, og kan umiddelbart ikke få akyhnes til at virke, mens din, supertekst, den fungere uden problemer, så kom endelig med et svar.

Så har jeg misforstået noget, for jeg kan ikke få superteksts til at virke.

Måske er det fordi jeg ikke så der først kom tal fra kolonne b:

Sub Makro1()
Dim MitArray, S As Long, I As Long, Y As Long, Temp
SlutR = Range("B1").SpecialCells(xlLastCell).Row
SlutC = Range("B1").SpecialCells(xlLastCell).Column
MitArray = Range(Cells(1, 2), Cells(SlutR, SlutC))

For S = 1 To UBound(MitArray)
    For I = 1 To UBound(MitArray, 2) - 1
        For Y = I To UBound(MitArray, 2)
            If MitArray(S, Y) > MitArray(S, I) Then
                Temp = MitArray(S, Y)
                MitArray(S, Y) = MitArray(S, I)
                MitArray(S, I) = Temp
            End If
        Next
    Next
Next
Range(Cells(1, 2), Cells(SlutR, SlutC)) = MitArray

End Sub

Jo, de virker ens nu. Du bestemmer selvfølgelig selv hvilken kode du bruger, men min kode er mange gange hurtigere end den supertekst lavede.

Det får du så

Ca. 30 gange hurtigere på 61000 rækker.

Jeg prøvede igen, men der bliver lavet rod i de første rækker.
Jeg ændrede "B1" til "B7" da det er første celle jeg har tallene i.
Det vender helt rundt på alle mine tal, men det er rigtigt at det går stærkt ;-)

Hvorfor giver du så point til supertekst? Er ydelse ikke en faktor?

Hvis der kun er tal fra række 7, ser koden således ud:

Sub Makro1()
Dim Start As Long, SlutR As Long, SlutC As Long, MitArray, S As Long, I As Long, Y As Long, Temp
Start = 7
SlutR = Range("B" & Start).SpecialCells(xlLastCell).Row
SlutC = Range("B" & Start).SpecialCells(xlLastCell).Column
MitArray = Range(Cells(Start, 2), Cells(SlutR, SlutC))

For S = 1 To UBound(MitArray)
    For I = 1 To UBound(MitArray, 2) - 1
        For Y = I + 1 To UBound(MitArray, 2)
            If MitArray(S, Y) > MitArray(S, I) Then
                Temp = MitArray(S, Y)
                MitArray(S, Y) = MitArray(S, I)
                MitArray(S, I) = Temp
            End If
        Next
    Next
Next
Range(Cells(Start, 2), Cells(SlutR, SlutC)) = MitArray

End Sub

@ akyhne: jo ydelse er en faktor, men hvis ikke jeg kan bruge den ene, mens den anden fugerer 1. gang, uden tilretning, så er jeg ikke i tvivl om hvor mine point forsvinder hen.
Jeg har endnu en gang forsøgt at bruge din makro, men den tager, så vidt jeg kan se hele rækken, og ikke som jeg startede med at gøre opmærksom på, kun 5 kolonner, nemlig B til F.
Jeg må erkende at jeg ikke kan gennemskue din makro, men jeg opretter da gerne en anden tråd, så du også kan få point, hvis du kan få den til at virke, som beskrevet.

Jeg hæftede mig ikke så meget i at der evt. kunne være andre celler med data. Derfor lavede jeg en "smart" makro, der finder hele området af celler i arket.

Og koden er nem at tilrette:

Sub Makro1()
Dim TopStart As Long, SlutR As Long, SlutC As Long, MitArray, S As Long, I As Long, Y As Long, Temp
TopStart = 7
SlutR = Range("B" & TopStart).SpecialCells(xlLastCell).Row
SlutC = 6 'kolonne F
MitArray = Range(Cells(TopStart, 2), Cells(SlutR, SlutC))

For S = 1 To UBound(MitArray)
    For I = 1 To UBound(MitArray, 2) - 1
        For Y = I + 1 To UBound(MitArray, 2)
            If MitArray(S, Y) > MitArray(S, I) Then
                Temp = MitArray(S, Y)
                MitArray(S, Y) = MitArray(S, I)
                MitArray(S, I) = Temp
            End If
        Next
    Next
Next

Range(Cells(TopStart, 2), Cells(SlutR, SlutC)) = MitArray
End Sub

Personligt mener jeg det er direkte dårlig programmering at anvende en kode der er 35 (med en lille rettelse) gange langsommere end en anden. Og jeg mener at effektiv og hurtig kode altid må være målet.

Med superteksts kode, bliver regnearket opdateret for hver række der sorteres i, altså for dit vedkommende 4000 gange. Med min kode, sker der kun en opdatering. Derfor er den hurtig. Alt beregning sker i hukommelsen, derfor er den hurtig.

Hvis to løsninger er lige gode, mener jeg det er første svar der bør have point. Hvis svarenene er kommet nogenlunde samtidig, ville jeg personligt nok dele mellem svarere.

Hvordan du fordeler point er din sag, men i dette tilfælde opfordrer den ikke ligefrem til at jeg skulle hjælpe dig en anden gang. Grund: Du fordeler point, uden at tage hensyn til min kommentar om at min kode er langt hurtigere.

Men skidt med pointene her, jeg håber blot at du finder anvendelse af min kode i dit ark.

Nu virker den som den skal, og jeg må gi dig ret, den er meget hurtig, faktisk så hurtig at jeg ikke nåede at opdage det...
JEg vil gerne give dig point også, men jeg ved ikke om jeg kan gøre det i denne tråd, hvis jeg kan, skal jeg muligvis have lidt hjælp til det, ellers opretter jeg bare en anden tråd, så du kan få de point du har fortjent.

Som skrevet: Skidt med pointene.

Jeg er enig i at hvis der er 2 svar, som er lige gode, bør de have point begge 2, men jeg kunne jo kun få supertekst's til at virke, selvom jeg havde prøvet de 2 første forslag fra din side, som ikke virkede.
Ville du så have at jeg skulle dele pointene mellem et rigtigt svar, i første hug, og så 2 som ikke virker?

Jeg skal kun have sorteret mit ark en gang, hvis ikke jeg går ind og tilføjer mere data, så hastigheden er ikke af den store betydning for mig, bortset fra at jeg ikke ville gøre det manuelt.

Grunden til at jeg fortsatte på denne tråd, er at jeg da mener du bør have den kredit for dit arbejde, men jeg nu ikke se jeg har gjort noget forkert i uddeling af point.
Jeg giver normalt kun point til dem som kan hjælpe mig, og hjælpen består for mit vedkommende i en løsning jeg kan bruge, jeg giver ikke point til alle dem der deltager i de tråde jeg har oprettet.
Du siger bare til hvis du vil have point :-)

Havde du givet udtryk for at der var andre data i arket, havde jeg rettet koden med det samme. Jeg skrev også at min kode virkede på samme måde, og langt hurtigere end superteksts kode, før du gav ham point. Men skidt, jeg har selv dummet mig ved ikke at læse spm. ordentligt.

Forbedring af hastigheden - når skærmopdatering slås fra:

Sub Overordnetsortering()
Dim ræk
    ræk = 7

    Application.ScreenUpdating = False
    Do
      Range("B" + CStr(ræk) & ":F" & CStr(ræk)).Select
      Selection.Sort Key1:=ActiveCell, Order1:=xlDescending, Header:=xlGuess, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, _
          DataOption1:=xlSortNormal
      ræk = ræk + 1
    Loop Until ActiveCell.Value = ""
 
    Application.ScreenUpdating = True
End Sub

Mit forslag nr. 1 tog ca. 3,5 sekunder. Forslag nr. 2 ca. 2,5 sekunder. supertekst1 tog 1 minut og 25 sekunder, supertekst2 ca. 27 sekunder.
superteksts kode skal indsætte resultat i hver række, derfor vil den altid være noget mere sløv.

Ved at bruge Application.EnableEvents = False, skæres yderligere 4 sekunder af, og med Application.Calculation = xlCalculationManual yderligere 4:

Sub Overordnetsortering2()
Dim ræk
    ræk = 7

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Do
      Range("B" + CStr(ræk) & ":F" & CStr(ræk)).Select
      Selection.Sort Key1:=ActiveCell, Order1:=xlDescending, Header:=xlGuess, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, _
          DataOption1:=xlSortNormal
      ræk = ræk + 1
    Loop Until ActiveCell.Value = ""
 
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Den tager 19 sekunder.