Zellfarbe mir übenehmen

[knallebumm]

Hallo,
ist es möglich folgen den Code anzupassen, so daß evtl. Zellfarben der Blätter auch mit übenommen werden?

Code:

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
  Dim i As Long
  Dim varQ As Variant
  If Sh.Name = "Einteilung alle Ligen" Then
    Sh.Range(Sh.Cells(5, 1), Sh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 10)) = ""
    For i = 1 To 4
      With Worksheets(i)
        If Len(.Cells(3, 1)) Then
          varQ = .Range(.Cells(3, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 9).Value
        Else
          ReDim varQ(0)
        End If
      End With
      If UBound(varQ) Then
        With Sh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(varQ))
          .Value = Worksheets(i).Name
          .Offset(, 1).Resize(, UBound(varQ, 2)).Value = varQ
        End With
      End If
    Next i
  End If
End Sub

Danke und Gruß
Thomas