Hi, danke für die Antwort, aber mein Code scheint sehr Komplex zu sein. Hab ihn mal hier her kopiert. Ist da irgendwo ein Fehler?
Option Explicit
Public AlterWert As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("K2:K" & Cells(Rows.Count, "K").End(xlUp).Row + 1)) Is Nothing _
And Target.Count = 1 Then _
AlterWert = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Tab2 As Range, rowOffset As Long, strAdress As String
Dim B As Long, A As Long, C As Long
Dim ws As Worksheet
Sheets("Gesamtdaten").Unprotect "gesamtdaten"
If Not Intersect(Target, Range("K2:K" & Cells(Rows.Count, "K").End(xlUp).Row + 1)) Is Nothing _
And _
Target.Count = 1 And Target = "" Then
ActiveWorkbook.Unprotect "daten"
For Each ws In Worksheets
If ws.Name = AlterWert Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next
ActiveWorkbook.Protect "daten"
End If
If Not Intersect(Target, Range("B3")) Is Nothing Then
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
On Error GoTo Fehler1:
With Tabelle2
rowOffset = .Rows(2).Find(What:=Range("B3"), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Column - 3
Range("B5:B" & Rows.Count).ClearContents
strAdress = .Range(.Cells(4, rowOffset), _
.Cells(56, rowOffset)).Address
.Range(strAdress).Copy Range("B5")
Range("E5:G" & Rows.Count).ClearContents
strAdress = .Range(.Cells(4, rowOffset + 1), _
.Cells(56, rowOffset + 5)).Address
.Range(strAdress).Copy Range("C5")
End With
ElseIf Not Intersect(Target, Columns(11)) Is Nothing Then
ArztAnlegen Intersect(Target, Columns(11))
Me.Activate
End If
Fehler1:
AnzeigeAn
If Err.Number 0 Then
MsgBox Err.Description, vbCritical, "Fehler beim Lesen!"
Sheets("Gesamtdaten").Protect "gesamtdaten"
Exit Sub
End If
On Error GoTo Fehler:
If Selection.Count > 1 Then
For C = 1 To Selection.Count
If Intersect(Selection(C), Range("E5:G56", "B5:B56")) Is Nothing Then _
Exit Sub
AnzeigeAn
B = Tabelle2.Rows(2).Find(What:=Range("B3"), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Column - 2
For A = 0 To 5
If A 3 Then
If A = 5 Then
Tabelle2.Cells(Selection(C).Row - 1, B - 1) = _
Cells(Selection(C).Row, 2).Value
Else
Tabelle2.Cells(Selection(C).Row - 1, B + A).Value = _
Cells(Selection(C).Row, 3 + A).Value
End If
End If
Next A
Next C
Else
If Intersect(Target, Range("E5:G56", "B5:B56")) Is Nothing Then Exit Sub
AnzeigeAn
B = Tabelle2.Rows(2).Find(What:=Range("B3"), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Column - 2
For A = 0 To 5
If A 3 Then
If A = 5 Then
Tabelle2.Cells(Target.Row - 1, B - 1) = Cells(Target.Row, 2).Value
Else
Debug.Print Cells(Target.Row, 3 + A)
Tabelle2.Cells(Target.Row - 1, B + A).Value = _
Cells(Target.Row, 3 + A).Value
End If
End If
Next A
End If
Fehler:
AnzeigeAn
If Err.Number 0 Then MsgBox Err.Description, vbCritical, _
"Fehler beim schreiben!"
Sheets("Gesamtdaten").Protect "gesamtdaten"
End Sub
Private Sub AnzeigeAn()
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Sub Gesamt()
Application.EnableEvents = True
Sheets("Gesamtdaten").Protect "gesamtdaten"
End Sub
Private Sub ArztAnlegen(rngB As Range)
Dim rngK As Range, lngI As Long
ActiveWorkbook.Unprotect "daten"
For Each rngK In rngB
If rngK.Row > 1 Then
If Len(rngK) "" Then
For lngI = 1 To Sheets.Count
If Sheets(lngI).Name = "" & rngK Then
MsgBox "Das Blatt " & rngK & " gibt es schon!"
Exit For
End If
Next lngI
If lngI > Sheets.Count Then
Sheets("Muster").Copy After:=Sheets(lngI - 1)
With ActiveSheet
.Name = rngK
.Cells(7, 4) = rngK
.Protect Password:=rngK
.Visible = True
End With
End If
End If
End If
Next rngK
ActiveWorkbook.Protect "daten"
End Sub
Danke für die Hilfe.
Gruß Oblivion