Themen übertragen

Private Sub CommandButton3_Click()
' Themen auf Mitarbeiter verteilen
Dim a
Dim i           As Long
Dim bis         As Long
Dim von         As Long
Dim Treffer     As Range
Dim Ws          As Worksheet
Dim FindStr     As String
Dim maxZell     As Long
Dim c           As Range
Dim rng         As Range
Dim Zell        As Range
Application.ScreenUpdating = False
For Each Ws In ThisWorkbook.Worksheets
Ws.Unprotect
Next
Set Treffer = Worksheets("Themenspeicher").Columns(2).Find("*Themenspeicher*", LookIn:= _
xlValues)
von = Treffer.Row + 1  'erste Zelle nach Themenspeicher in Sheet Themenspeicher
bis = Worksheets("Themenspeicher").Range("B" & Rows.Count).End(xlUp).Row + 1
a = Range("B" & von & ":F" & bis)
For i = 1 To UBound(a)
If a(i, 2) = "x" Then
bis = Sheets(a(i, 3)).Range("B2000").End(xlUp).Row + 1
bis1 = Sheets(a(i, 4)).Range("C2000").End(xlUp).Row + 1
Ab = Application.Match("aus Themenspeicher übertragen", Worksheets(a(i, 3)).Range("B: _
B"), 0)
Ab1 = Application.Match("Termin", Worksheets(a(i, 4)).Range("C:C"), 0)
'Doppelte Werte werden vermieden
If IsError(Application.Match(a(i, 1), Worksheets(a(i, 3)).Range("B" & Ab & ":B" &  _
bis), 0)) _
& IsError(Application.Match(a(i, 4), Worksheets(a(i, 3)).Range("C" & Ab1 & ":C" &  _
bis1), 0)) _
Then
Sheets(a(i, 3)).Range("B" & bis) = a(i, 1)
Sheets(a(i, 3)).Range("C" & bis) = a(i, 4)
Sheets(a(i, 3)).Range("B8:C8").Copy  ' da ist das gleiche Format
Sheets(a(i, 3)).Range("B" & bis).Resize(, 2).PasteSpecial xlFormats
Sheets(a(i, 3)).Range("B" & bis).HorizontalAlignment = xlLeft
Sheets(a(i, 3)).Range("C" & bis).NumberFormat = "dd.mm.yyyy"
End If
End If
Next
...