aktive Zelle farbig, Code anpassen

Hallo an Forum,
nachfolgenden Code habe ich von Hajo's HP.
Wie muss der Code angepasst werden, das er nur die aktiven Zellen in einem Tabellenblatt (bei mir heisst das Blatt Kalkulation) markiert?
Vielen Dank in Voraus an die Helfer!
MfG Christian
Option Explicit
'**************************************************
'* H. Ziplies *
'* 24.07.05 komplette Überarbeitung des Code *
'* erstellt von Hajo.Ziplies@web.de *
'* http://Hajo-Excel.de/ *
'**************************************************
' Farbformatierungen während der Selektion bleiben erhalten, außer ByFarbe
' Abschalten der Markierung durch Doppelklick
Dim BoAktion As Boolean ' Zustand der Markierung
Dim StName As String ' CodeName der Tabelle
Dim StWert(256, 1) As String ' 0=Zelladresse; 1=Farbe der Zelle
Dim InI As Integer ' Schleifenvariable
Dim ByFarbe As Byte ' Farbe der Markierung 1 bis 56

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If BoAktion Then Exit Sub                                       ' Markierung aus
'   nach Hinweis von Peter Haserodt Vergleich eingefügt ob Tabelle
If TypeName(ActiveSheet) = "Worksheet" Then Zurück              ' Farben zurückstellen
End Sub

Private Sub Workbook_Open()
If Selection.Cells.Count > 257 Then Exit Sub                     ' mehr als die mögliche  _
Anzahl markiert
'   nach Hinweis von Peter Haserodt Vergleich eingefügt ob Worksheet
If TypeName(ActiveSheet) = "Worksheet" Then Auslesen    ' Farbe auslesen
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If BoAktion Then Exit Sub                               ' Markierung ausgeschaltet
Zurück                                                  ' Farben zurückstellen
If Target.Count > 257 Then Exit Sub                     ' mehr als die mögliche Anzahl  _
markiert
'   nach Hinweis von Peter Haserodt Vergleich eingefügt ob Tabelle
If TypeName(ActiveSheet) = "Worksheet" Then Auslesen    ' Farben der aktuellen Zeile  _
auslesen
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
If BoAktion Then Exit Sub                               ' Markierung ausgeschaltet
'   nach Hinweis von Peter Haserodt Vergleich eingefügt ob Tabelle
If TypeName(ActiveSheet) = "Worksheet" Then Zurück      ' Farben zurückstellen
End Sub

Private Sub Workbook_BeforePrint(Cancel As Boolean)
'   falls Farbe beim Druck wieder zurückgestellt werden soll
'   nach Druck ist die aktuelle Zelle nicht markiert
If BoAktion Then Exit Sub                               ' Markierung ausgeschaltet
'   nach Hinweis von Peter Haserodt Vergleich eingefügt
If TypeName(ActiveSheet) = "Worksheet" Then Zurück      ' Farben zurückstellen
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If BoAktion Then Exit Sub                               ' Markierung ausgeschaltet
Zurück                                                  ' Farben zurückstellen
'   nach Hinweis von Peter Haserodt Vergleich eingefügt
If TypeName(ActiveSheet) = "Worksheet" Then
If Selection.Cells.Count > 257 Then Exit Sub        ' mehr als die mögliche Anzahl  _
markiert
Auslesen
End If
End Sub

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
If BoAktion Then Exit Sub                               ' Markierung ausgeschaltet
'   nach Hinweis von Peter Haserodt Vergleich eingefügt
If TypeName(ActiveSheet) = "Worksheet" Then Zurück      ' Farbe zurückstellen
End Sub

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel  _
As Boolean)
BoAktion = Not BoAktion                                 ' Markierung umschalten
'   nach Hinweis von Peter Haserodt Vergleich eingefügt
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub   ' keine Tabelle
If BoAktion Then                                        ' Markierung ausgeschaltet
Zurück                                              ' Farben zurückstellen
Else
Auslesen                                            ' Farben auslesen
End If
Cancel = True                                           ' Cursor in Zelle abschalten
End Sub

Private Sub Zurück()
Dim StKlarname As String                    ' Klarname der Tabelle
If StName = "" Then Exit Sub                ' die Variable ist noch nicht belegt
'   Klarname der Tabellle feststellen
Dim WsTabelle As Worksheet
For Each WsTabelle In Worksheets            ' Schleife über alle Tabellen
If WsTabelle.CodeName = StName Then     ' Namen mit abgespeicherten vergleichen
StKlarname = WsTabelle.Name         ' Namen auf Register auslesen
Exit For                            ' Schleife verlassen
End If
Next WsTabelle
If StKlarname = "" Then                     ' Tabelle wurde gelöscht
StWert(0, 1) = ""                       ' ersten vorhanden Wert löschen, die Werte  _
werden nicht mehr benötigt
Exit Sub
End If
'   Farben zurückstellen
With Worksheets(StKlarname)
For InI = 0 To 256
If StWert(InI, 1) = "" Then Exit For ' keine weiteren Werte vorhanden
' ist die Zelle mit ByFarbe markiert alte Zellenfarbe zurücksetzen
If .Range(StWert(InI, 0)).Interior.ColorIndex = ByFarbe Then
.Range(StWert(InI, 0)).Interior.ColorIndex = CInt(StWert(InI, 1))
End If
Next InI
'        .Protect "Passwort"
End With
End Sub

Private Sub Auslesen()
Dim RaZelle As Range
ByFarbe = 3                                         ' Farbe der Markierung
InI = 0
StName = ActiveSheet.CodeName                       ' CodeName der Tabelle
'    ActiveSheet.Unprotect "Passwort"                    ' Schutz aufheben
For Each RaZelle In Selection                       ' Schleife über alle markierten Zellen
StWert(InI, 0) = RaZelle.Address                ' Zelladresse
StWert(InI, 1) = RaZelle.Interior.ColorIndex    ' Farbe der Zelle
RaZelle.Interior.ColorIndex = ByFarbe           ' Zelle mit Farbe markieren
InI = InI + 1                                   ' Laufvariable erhöhen
Next RaZelle
'    ActiveSheet.Protect "Passwort"                      ' Schutz aufheben
If InI < 256 Then StWert(InI + 1, 1) = ""           ' den nächsten alten Farbwerte löschen
End Sub