gruss zu später stundezur frage der dimensionrung habe weiter unten einen code veröffentlicht mit andre und bin da nicht weitergekommen ...ich kopiere in noch mal rein ....
es passiert leider nichts ....der bereich wird nicht selectiert ...??
Sub Sort_KZ()
Worksheets("Tabelle1").Activate
Application.WindowState = xlMaximized
'Datenbereich finden (Hintergrundfarbe 37)
ActiveSheet.Range("B24").Select
For ActRow = 1 To 600000
If ActiveCell.Offset(ActRow, 0).Interior.ColorIndex <> 37 Then Exit For
Next ActRow
PTWdata = "Tabelle!R24C2:R" & Trim(Str(24 + ActRow - 1)) & "C19"
On Error Resume Next
'Datenbereich nach "1" in der Spalte S sortieren
Range("PTWdata").Select
Selection.Sort Key1:=Range("S25"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Range("B39").Select
'Nach sortierung Datenbereich neu ausrechnen letzte zeile hat eine andere Farbe
ActiveSheet.Range("B24").Select
For ActRow = 1 To 600000
If ActiveCell.Offset(ActRow, 0).Interior.ColorIndex <> 37 Then Exit For
Next ActRow
'neuer Datenbereich
PCopydata = "Tabelle1!R24C2:R" & Trim(Str(24 + ActRow - 1)) & "C19"
'Datenbereich von PCOpydata nach Tabelle 2 kopieren und zurückkehren nach Tabelle1
'Ab hier funktioniert es nicht mehr ...vielleicht kommt das change ereignis von userform in die quere ..
'ich weiss es nicht
Range("PCopydata").Select
'Range("A24:S37").Select
'Range("S24").Activate
Selection.Copy
'Application.EditDirectlyInCell = False
Application.CutCopyMode = False
Sheets("Tabelle2").Select
Range("A24").Select
ActiveSheet.Paste
Sheets("Tabelle1").Select
Application.CutCopyMode = False
'nicht selectierte Datensätze von Tabelle 1 löschen ....zukunftsmusik
bitte ...vielleicht hast du eine idee es sind schon viele,viele stunden ohne ergebnis ....*ggg*