sorter x-antal linier

vis et eks... der er god mulighed for misforståelser her

eks.
B5 = grp. 10
B6-B44 = firmanavn, A+C-O = div., P = beløb
B45 = grp. 18
B46-B47 = firmanavn, A+C-O = div., P = beløb
B48 = grp. 26
B49-B69 = firmanavn,  A+C-O = div., P = beløb
osv.
Skemaet slutter med teksten Total i Bxxx 

På næste mandag kan der så muligvis være kommet en linie ind i række47, så det hele er rykket en linie ned.

/dan

dvs. at linier som starter med grp  skal blive stående ?

er der kun værdier i kolonne B og P ? eller skal hele linien flyttes

Ja, linier med grp er en total for de nedenstående linier.
Ja, hele linien skal flyttes/sorteres.

/dan

prøv lige på en kopi først

Sub SpecialSort()
Application.ScreenUpdating = False
Dim x()
Sheets("Ark1").Select
rk = Cells(1000, "B").End(xlUp).Row
ReDim x(rk)
For t = 1 To rk
If Cells(t, "B") Like "grp*" Then x(t) = Cells(t, "P").Formula: Cells(t, "P") = ""
Next
On Error Resume Next
For t = 1 To rk
If Cells(t, "B") <> "" And Cells(t, "B") <> "grp*" And Cells(t, "P") <> "" Then
rng = Range("A" & t & ":IV" & t)
maxtal = Application.WorksheetFunction.Max(Range("P" & t & ":P" & rk))
maxrk = Range("P" & t & ":P" & rk).Find(maxtal, LookIn:=xlValues).Row
Range("A" & maxrk & ":IV" & maxrk).Copy Range("A" & t & ":IV" & t)
Range("A" & maxrk & ":IV" & maxrk) = rng
End If
Next
For t = 1 To rk
If Cells(t, "B") Like "grp*" Then Cells(t, "P").Formula = x(t)
Next
Application.ScreenUpdating = True
End Sub

Der kommer en besked med:
Subscript out of range

Kan det være fordi jeg har glemt at nævne, at grp først begynder ved 4. tegn.

/dan

tror det er manglende dimensionering af variable
hvis du har følgende linie i toppen af modulet så remark den
Option Explicit
ret evt. Ark1 til aktuel

Selvfølgelig skal man huske at skifte arknavn :-)

Uden option Explicit, kommer der denne fejl ved ReDim x(rk): type mismatch
Med option Explicit, kommer der denne fejl ved rk = Cells: Variable not defined

/dan

ok prøv med denne

Sub SpecialSort()
Application.ScreenUpdating = False
Dim x()
dim t,rk,rng,maxtal,maxrk
Sheets("Ark1").Select
rk = Cells(1000, "B").End(xlUp).Row
ReDim x(rk)
For t = 1 To rk
If Cells(t, "B") Like "grp*" Then x(t) = Cells(t, "P").Formula: Cells(t, "P") = ""
Next
On Error Resume Next
For t = 1 To rk
If Cells(t, "B") <> "" And Cells(t, "B") <> "grp*" And Cells(t, "P") <> "" Then
rng = Range("A" & t & ":IV" & t)
maxtal = Application.WorksheetFunction.Max(Range("P" & t & ":P" & rk))
maxrk = Range("P" & t & ":P" & rk).Find(maxtal, LookIn:=xlValues).Row
Range("A" & maxrk & ":IV" & maxrk).Copy Range("A" & t & ":IV" & t)
Range("A" & maxrk & ":IV" & maxrk) = rng
End If
Next
For t = 1 To rk
If Cells(t, "B") Like "grp*" Then Cells(t, "P").Formula = x(t)
Next
Application.ScreenUpdating = True
End Sub

nu går excel bare kold....

/dan

Koden virker fint i mit testark
hvis ikke du kan finde mulige problemårsager ved sammenlig
så prøv send filen til mig.
http://pmexcelent.dk/xSort.xls

du skal gemme filen lokalt ellers virker koden ikke

har kopieret koden fra dit eks.
højreklik på faneark - vis program kode - 'sæt ind', ændre "Ark1" til "TEST".

excel går stadigvæk kold :-(
sender gerne til, hvilken mail!

/dan

koden skal ind i et alm modul
i arket taster du ALT+F11
vælg Module i menuen Insert
paste koden i vinduet

ellers

pm@madsen.tdcadsl.dk

husk lige slet koden i arkets kodemodul (skal kun være i et modul)

Har set på arket igen, det er vist ikke så vanskeligt alligevel.

Kolonne A indeholder tal som referere til grp. dvs. 100, 180, 260 osv.
Jeg prøvede manuelt ved at markere alle linier hvor Kolonne A indeholder 100 også sortere faldende på Kolonne A og derefter Kolonne P
Resultatet er tilfredsstillende.

Men hvordan laves koden til det? (hele arket kan ikke sorteres på gang - har prøvet)

/dan

Vil det sige at der kun skal sorteres faldende inden for hver gruppe
og ikke faldende inden for hele arket ?
Som du kan se virker koden ok på mit testark, men der kan naturligvis være forhold hos dig som driller.
Du er stadig velkommen til at sende arket hvis...
men kikker først på det efter arb,tid.

Ja, det er korrekt.
Test ark sendt.

Jeg venter med spænding.

/dan

Har modtaget arket retur....
Fungerer perfekt.
Har ændret så det efterfølgende sortere på kolonne O og derefter B.

/dan
---------
Application.ScreenUpdating = False
Set sh = Sheets("excel")
sh.Select

rk1 = Range("A1").End(xlDown).Row
rng = Range("A" & rk1 & ":A" & Cells(65500, 1).End(xlUp).Row).Address
om:
værdi = Cells(rk1, 1)
antal = Application.WorksheetFunction.CountIf(Range(rng), værdi)
If antal > 1 Then Range("B" & rk1 + 1 & ":P" & rk1 + antal - 1).Select

Selection.Sort Key1:=Range("P" & rk1), Order1:=xlDescending, Key2:=Range("O" & rk1) _
        , Order2:=xlDescending, Key3:=Range("B" & rk1), Order3:=xlAscending, Header _
        :=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
        xlSortNormal

rk1 = rk1 + antal
If Cells(rk1, 1) <> "" Then GoTo om
Cells(1, 1).Select
Application.ScreenUpdating = True
---------

ok velbekom

Tak for hjælpen.