Excel 2007 Sortere via VBA

Public Sub udførSortering()
    ActiveWorkbook.Worksheets("Ark1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Ark1").Sort.SortFields.Add Key:=Range("C2:C201"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
   
    ActiveWorkbook.Worksheets("Ark1").Sort.SortFields.Add Key:=Range("B2:B201"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
   
    With ActiveWorkbook.Worksheets("Ark1").Sort
        .SetRange Range("B1:C201")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Tæt på.  :-)

Men når jeg indtaster 5 tilfældige resultater, så sorterer den dem godt nok, men de står i rækkerne 197, 198, 199, 200 og 201
Altså i bunden.

De skulle gerne stå i rækkerne 2, 3, 4, 5 og 6

Jeg har ændret koden til:

Public Sub udførSortering()
    ActiveWorkbook.Worksheets("Opfølgningsark").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Opfølgningsark").Sort.SortFields.Add Key:=Range("C2:C201"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
   
    ActiveWorkbook.Worksheets("Opfølgningsark").Sort.SortFields.Add Key:=Range("B2:B201"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
   
    With ActiveWorkbook.Worksheets("Opfølgningsark").Sort
        .SetRange Range("B1:C201")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Så er det (vel) fordi der ikke er værdi i de øvrige rækker. I sorteringen er række 201 den sidste.

Prøv at kopier værdier til og med række 201 ..

Ellers skal der indlægges en sætning der finder den sidste række - det er intet problem...

Nej, der er ingen værdier i alle rækker. Som jeg skriver i spørgsmålet kommer resultaterne løbende.

Det kan f.eks. være i række 3, 22, 52, 81 og 107
Det er helt vilkårligt, hvor de løber ind.
Alle bliver sikkert ikke fyldt ud.

Koden skal så sortere dem fra toppen.

Min fejl, at det ikke var beskrevet godt nok, sorry.....

Ok - men de tomme rækker må ikke slettes?

Kunne man tænke sig, at hver gang et tal blev indtastet blev sortering udført/eller på anfordring og vist i kolonnerne D - F?

Nej, tomme rækker må ikke slettes....

Data hentes fra 40 andre ark, 5 poster pr, ark.
Herefter er det tanken at de sorteres i arket: Opfølgningsark
Og til slut hentes sorterede data over i et ark kaldet Resultatliste. Her kan jeg så printe en resultatliste, som den ser ud med de data som er kommet indtil nu.
Der vil helt sikkert forekomme "huller" i resultaterne, de skulle gerne sorteres fra (eller nederst, når der ikke findes data)

Det kunne sikkert laves meget mere smart, men sådan har jeg bygget det op fra start.
Jeg har tidligere brugt at sortere manuel i Opfølgningsark, det funker sådan set ok. Kunne bare godt tænke mig at sortere, bare ved at trykke på en knap.

Det gør den så nu, desværre bare fra bunden.  :-)

Jeg uploader lige arket, hvis du vil se den: http://gupl.dk/64974/

Der er indtastet data til forsøg i arkene Hold1, Hold(2) og Hold(6)

Som du kan se, er de placeret nederst efter jeg har afspillet makroen....

Ok - modtaget - ser på det i morgen..

Du nævner, at du har sorteret manuelt - hvis det var ok - så prøv at indspille en makro med den samme procedure.

Godt forslag.  :-)

Og når jeg prøver at sotere manuel, opdager jeg, at jeg er nødt til at fuske, for at det funker. Den gør det nemlig også fra bunden....  :-)

Men det er også et år siden jeg brugte den sidst, det havde jeg glemt.
Men nu kan jeg huske, at jeg satte et 1 tal ind i de tomme resultater, så smed den dem ned i bunden. Og så kunne jeg printe en resultatliste.
Jeg skulle så huske at fjerne de 1 taller igen, det er det jeg gerne vil undgå......

Hmmm, det er nok ikke så let som jeg lige troede......

Tak for meldingen - jeg skal nok se på det igen i en ledig stund.

Hej Vejmand

Har du mulighed for at uploade eller sende følgende:
Opfølgningsarket - UDEN der er sorteret
Resultatliste  - I DET ØNSKEDE udseende - "manuel sorteret"

stadig på basis af de tidligere uploadede data.

Kommer her: http://gupl.dk/64988/

Forklaring:
Der er indtil videre kun data i Arkene Hold1 og Hold(2)
Og der er "huller" i disse data, så der har jeg givet 1 point, så hullerne er væk.

Nu har jeg så sorteret manuel, ved at markere de øverste data i opfølgningsarket. Herefter sletter jeg de 1 taller jeg har indsat i Hold1 og Hold(2), og jeg kan printe en resultatliste, som ser rigtig ud.

Det er for at jeg kan printe en resultatliste løbende, så det er lidt bøvlet. Næste gang jeg vil printe, skal jeg igen indsætte disse 1 point inden jeg sorterer. Det ville jeg gerne være fri for.

Jeg er først tilbage senere i eftermiddag......

Tak for det - men jeg vil meget gerne se Opfølgningsarket UDEN der er sorteret på nogen måde.

Resultatlisten er tydeliggjort.

Okay, her kommer den helt uden sortering.
Der er igen kun indtastet data i Hold1 og Hold(2)

http://gupl.dk/65026/

Tusind tak for din tålmodighed, jeg vidste ikke nøden var så hård at knække.  :-)

Jeg har fundet en løsning, som kan bruges, hvis du ikke kan knække den som den er nu.

I hvert ark (Hold) har jeg ud for hver person en formel til sammentælling:
=HVIS(SUM(B7:AE7)+SUM(B9:AE9)>0;SUM(B7:AE7)+SUM(B9:AE9);"")
Så skriver den ikke noget, hvis der ingen resultater er.

Den har jeg forsøgsvis ændret til:
=SUM(B7:AE7)+SUM(B9:AE9)
Nu skriver den 0 (nul) hvis der ingen resultater er, og det gør den også i Opfølgningsarket.
Og så kan den sortere med den kode du kom med.

De nuller kan jeg nok godt leve med, hvis det skal være.  :-)

Under alle omstændigheder, send et "Svar" til point for forsøget.

Og tak for indsatsen.  :-)

Tak - vender tilbage tirsdag..

PS Kan ikke downloade filen - får time-out...

Evt prøv at sende filen direkte - @-adresse under min profil.

Fil sendt til e-mail......

Det kommer nok til at vare lidt længere...

Rem Version pr. 07-09-11

Dim rækS As Long
Dim arkR As Worksheet
Public Sub udførSortering()
    Application.ScreenUpdating = False
   
    forBehandling
    sortering
    efterBehandling

    Application.ScreenUpdating = True
   
    arkR.Activate
    arkR.Range("A1").Select
End Sub
Private Sub forBehandling()
Dim ræk As Long
Rem indsæt 2 kolonner
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    rækS = 0
   
    For ræk = 2 To 201
        If Range("D" & ræk) <> 0 And Range("E" & ræk) <> 0 Then
            rækS = rækS + 1
            Range("A" & rækS) = Range("D" & ræk)
            Range("B" & rækS) = Range("E" & ræk)
        End If
    Next ræk
End Sub
Private Sub sortering()
Const arkNavn = "Opfølgningsark"
    ActiveWorkbook.Worksheets(arkNavn).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(arkNavn).Sort.SortFields.Add Key:=Range("B1:B" & rækS), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
   
    ActiveWorkbook.Worksheets(arkNavn).Sort.SortFields.Add Key:=Range("A1:A" & rækS), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
   
    With ActiveWorkbook.Worksheets(arkNavn).Sort
        .SetRange Range("A1:B" & rækS)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
Private Sub efterBehandling()
Dim ræk As Long, fundetRække As Long
    Set arkR = ActiveWorkbook.Sheets("Resultatliste")
   
    For ræk = 1 To rækS
        fundetRække = søgKolonneA(ræk)
        If fundetRække > 0 Then
            arkR.Range("B" & fundetRække) = Range("A" & ræk)
            arkR.Range("C" & fundetRække) = Range("B" & ræk)
        Else
            fundetRække = søgKolonneF(ræk)
            If fundetRække > 0 Then
                arkR.Range("G" & fundetRække) = Range("A" & ræk)
                arkR.Range("H" & fundetRække) = Range("B" & ræk)
            Else
                MsgBox "Resultat-række: " & CStr(fundetRække) & " ej fundet - kørsel afbrydes"
                Exit For
            End If
        End If
    Next ræk

    Columns("A:B").Select
    Selection.Delete
End Sub
Private Function søgKolonneA(søgeKriterie)
    With arkR.Range("A2:A116")
   
        Set c = .Find(What:=søgeKriterie, LookIn:=xlValues, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, SearchDirection:=xlNext)

            If Not c Is Nothing Then
                søgKolonneA = c.Row
                Exit Function
            Else
                søgKolonneA = 0
            End If
    End With
End Function
Private Function søgKolonneF(søgeKriterie)
    With arkR.Range("F2:F88")
   
        Set c = .Find(What:=søgeKriterie, LookIn:=xlValues, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, SearchDirection:=xlNext)

            If Not c Is Nothing Then
                søgKolonneF = c.Row
                Exit Function
            Else
                søgKolonneF = 0
            End If
    End With
End Function

Så tror jeg det spiller.
Tusind tak for hjælpen, det havde jeg aldrig selv fundet ud af.  :-)

Selv tak - det har været en fornøjelse...