Ich brauche hilfe um beide zu verbinden. Einzeln funktionieren beide wunderbar, aber ich brauche sie in einem Tabellenblatt.
Der kleine Code soll in den großen integriert werden, sofern dies möglich ist.
Ich schon mal versucht es zu verbinden, aber ich habe es nicht hinbekommen.
Hier sind die beiden Codes:
Der kleine Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RaBereich As Range, RaZelle As Range
Set RaBereich = Range("K1:L52")
Set RaBereich = Intersect(RaBereich, Range(Target.Address))
If RaBereich Is Nothing Then Exit Sub
Range("K1:L52").Sort Key1:=Range("K2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Set RaBereich = Nothing
End Sub
Der große Code:
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
Dim RaBereich As Range, RaZelle As Range
Sheets("Gesamtdaten").Protect Password:="gesamtdaten", UserInterfaceOnly:=True
If Not Intersect(Target, Range("K2:K" & Cells(Rows.Count, "K").End(xlUp).Row + 1)) Is Nothing _
And _
Target.Count = 1 And Target.Address > "" 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(62, 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!"
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:G62", "B5:B62")) 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:G62", "B5:B62")) 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!"
End Sub
Private Sub AnzeigeAn()
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Sub Gesamt()
Application.EnableEvents = True
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
Ich hoffe ihr könnt mir helfen. Ich danke schon mal für jede Antwort.
Grüße Oblivion