Hallo Sebastian,

außer dass dein Code über 2 Schlüssel (Name?, Vorname?) sortiert, gibst du über deine Datenstruktur leider nur wenig Auskunft (Urlaubsplan, wer hätte das gedacht ist nicht der Einkaufszettel ;-)

Generell verwendet man(n) in der Personalverwaltung sog. (eindeutige) Personalnummern.

Die sollten auch in den Datentabellen als Primärschlüssel abgebildet sein – Formel (=Sheets1!A..)

Selbstplaudernd kannst du auch andere Verweise auf Namen etc. solcherart setzen.

Die Idee mit dem Zustand merken und wiederherstellen ist schon richtig, aber – Erfolg durch Aufwand:

VBA kann die Formeln "nach" – u. "zurückverfolgen (ShowDependents, NavigateArrow), das ist einfacher als .Find & Co.

Für jeden nicht zusammenhängenden Bereich von "Werten" (also nicht Formeln) benutzt du eine SortedList als Zwischenspeicher. Key = Primärschlüssel, Value = Einzelwert oder ein Datenfeld(Array) des Bereiches.

Nach der Sortierung wiederholst du den Vorgang der Verfolgung.  Jetzt suchst du über den Primärschlüssel den key der SortedList und überträgst dessen value  wieder an die Position der Datentabelle.

Einfaches Beispiel :

'**********************************************************************************************
' Modul: mdl_SpecialeSort / erstellt am : 27.04.2012
'----------------------------------------------------------------------------------------------
' Zweck / Inhalt :
' Sortierung mit "verknüpften" Daten(zeilen)
' F:\Consult\Adminx\employees\2012x - cmp-structure
'
' Sheets(1) - "Tabelle1" Stammdaten
' Pers.Nr, Name, Vorname, geb., Alter(Formel), Anspruch(Formel)
' A1 Nr,
' B1 Name
' C1 Vorname
' D1 geb.
' E1 Alter
' F1 Anspruch
' Daten ab Zeile 2, Spalte 1
'
' Sheets(2) - "Tabelle2" Urlaubstage Übersicht
' Pers.Nr(Formel), Name(Formel), Vorname(Formel), Abteilung, Jan. - Dez. - Felder, Rest(Formel)
' A1 Nr, - z.B. =Tabelle1!A2
' B1 Name - ditto Formel
' C1 Vorname - ditto Formel
' D1 Abteilung - Wert
' E1 Anspruch -z.B. =Tabelle1!F2
' F1 Jan. - Wert
' G1 Feb. - ditto
' H1 März
' I1 April
' J1 Mai
' K1 Juni
' L1 Juli
' M1 August
' N1 Sept.
' O1 Okt.
' P1 Nov.
' Q1 Dez. - Wert
' R1 Rest - z.B. =E2-SUMME(F2:Q2) lokale Formel
' Daten ab Zeile 2, Spalte 1
'
'**********************************************************************************************

Option Explicit
'global
Dim oSlist1 As Object, oSlist2 As Object
Dim oWsh1 As Worksheet, oWsh2 As Worksheet

Sub SortIt()
   BeforeSort 'Zustand sichern
   DoSort
   AfterSort   'Wiederherstellen
Set oSlist1 = Nothing
Set oSlist2 = Nothing
End Sub

Sub AfterSort()
'
'******************************************************************************
' Name : AfterSort / erstellt : 28.04.2012 / 11:48 / Sub
'------------------------------------------------------------------------------
' Relationen wie gehabt wiederherstellen
' und die gesicherten Inhalte aus den SortedLists-Objekten zurück
' it´s easy
'******************************************************************************
'
Dim rngRel As Range, c As Range
Dim rngFound As Range
Dim arrKalender()

Set oWsh1 = ThisWorkbook.Sheets(1)  'Stamm
Set oWsh2 = ThisWorkbook.Sheets(2)  'Urlaub

Application.ScreenUpdating = False
With oWsh1
   .Activate
   
   'Bereich Relationen
   'Spalten haben Überschrift, daher
   Set rngRel = .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
   If rngRel.Rows.Count = Rows.Count - 1 Then Exit Sub   ' < 2 Datenzeilen
   'über die Relation
   For Each c In rngRel
      .ClearArrows
      c.ShowDependents  'über die Formelnachverfolgung
      Set rngFound = c.NavigateArrow(False, 1, 1)
      rngFound.Offset(, 3).Value = _
      oSlist1.getByIndex(oSlist1.IndexOfKey(rngFound.Value))
      arrKalender = oSlist2.getByIndex(oSlist2.IndexOfKey(rngFound.Value))
      Set c = rngFound.Offset(, 5).Resize(UBound(arrKalender, 1), UBound(arrKalender, 2))
      c.Value = arrKalender
      oWsh1.Activate
      .ClearArrows
   Next c
   
End With
Application.ScreenUpdating = True

Set oWsh1 = Nothing
Set oWsh2 = Nothing

End Sub

Sub DoSort()
'
'******************************************************************************
' Name : DoSort / erstellt : 28.04.2012 / 11:20 / Sub
'------------------------------------------------------------------------------
' was ist eigenlich egal - ergo 1 x über Name u. Vorname
'
'
'******************************************************************************
'
Set oWsh1 = ThisWorkbook.Sheets(1)  'Stamm
Dim rngSort As Range 'Bereich
Dim strSort As String   'ditto Adresse
Dim strKey1 As String, strKey2 As String 'Adresse der Schlüsselspalten

With oWsh1
   Set rngSort = Range("A1").CurrentRegion
      strSort = rngSort.Address
      strKey1 = rngSort.Columns(2).Address
      strKey2 = rngSort.Columns(3).Address
   
   With .Sort
      With .SortFields
         .Clear
         .Add Key:=Range(strKey1) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add Key:=Range(strKey2) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
      End With
      .SetRange Range(strSort)
      .Header = xlYes
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
   End With
End With

Set oWsh1 = Nothing
End Sub

Sub BeforeSort()
'
'******************************************************************************
' Name : BeforeSort / erstellt : 27.04.2012 / 18:00 / Sub
'------------------------------------------------------------------------------
' Relation ist die Spalte A (Nr.)
' 2 neue SortedList Objekte, da Abteilung und Kalender nicht zusammenhängend !
' über die Realtion Nr. füllen
'******************************************************************************
'

Dim rngRel As Range, c As Range
Dim rngFound As Range
Dim arrKalender() As Variant

Set oWsh1 = ThisWorkbook.Sheets(1)  'Stamm
Set oWsh2 = ThisWorkbook.Sheets(2)  'Urlaub
Set oSlist1 = CreateObject("System.Collections.Sortedlist")  'für die Abteilung
Set oSlist2 = CreateObject("System.Collections.Sortedlist")  'für die Monate

Application.ScreenUpdating = False
With oWsh1
   .Activate
   
   'Bereich Relationen
   'Spalten haben Überschrift, daher
   Set rngRel = .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
   If rngRel.Rows.Count = Rows.Count - 1 Then Exit Sub   ' < 2 Datenzeilen
   'über die Relation
   For Each c In rngRel
      .ClearArrows
      c.ShowDependents  'über die Formelnachverfolgung
      Set rngFound = c.NavigateArrow(False, 1, 1)
      oSlist1.Add c.Value, rngFound.Offset(, 3).Value ' Spalte D
      arrKalender = Range(rngFound.Offset(, 5), rngFound.Offset(, 16))
      oSlist2.Add c.Value, arrKalender 'Spalte F-Q als Datenfeld
      oWsh1.Activate
      .ClearArrows
   Next c
   
End With
Application.ScreenUpdating = True

Set oWsh1 = Nothing
Set oWsh2 = Nothing

End Sub