Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1012to1016
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Zwei Worksheet_Change ereignisse verbinden

Zwei Worksheet_Change ereignisse verbinden
01.10.2008 09:43:00
oblivion
Hallo, ich habe zwei Programmcodes. Es sind beide Worksheet_Change-Ereignisse.
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

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zwei Worksheet_Change ereignisse verbinden
02.10.2008 01:36:00
Daniel
Hi
wenn du den kleinen Code so abänderst:

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 Not RaBereich Is Nothing Then
Range("K1:L52").Sort Key1:=Range("K2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Set RaBereich = Nothing
End if
End Sub


solltest du eigentlich den kleinen in den grossen Code problemlos integrieren können, es werden beide nacheinander abgearbeitet.
das kleine Makro würde ich nach vorne stellen.
lediglich bei den DIM-Anweisungen musst du noch prüfen, daß keine Variablen doppelt dimensioniert werden.
Gruß, Daniel

Anzeige
AW: Zwei Worksheet_Change ereignisse verbinden
02.10.2008 13:27:11
oblivion
Hallo, danke für deine Antwort. Hab es grad ausprobiert und nach einigem hin und her hat es auch geklappt.
Allerdings hat sich ein neues Problem aufgetan.
Im großen Code wird ja ein neues Tabellenblatt erstellt, wenn ich in der Spalte K einen Namen reinschreibe. Das klappt ja auch alles super. Und wenn ich den Namen wieder lösche, wird das entsprechende Tabellenblatt wieder gelöscht.
Nun ist es aber mit dem sortieren so, dass er nach jedem sortieren auch wieder ein neues Tabellenblatt mit den entsprechenden Namen erstellen möchte.
Meine Frage wäre also, kann man das erstellen der neuen Tabellenblätter so einschränken, dass dies nur bei Eingabe erfolgt und nicht jedesmal, wenn er die Tabelle neu sortiert.
Hier ist nochmal der ganze 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
Set RaBereich = Range("K1:L52")
Set RaBereich = Intersect(RaBereich, Range(Target.Address))
If Not RaBereich Is Nothing Then
Range("K1:L52").Sort Key1:=Range("K2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Set RaBereich = Nothing
End If
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(62, 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


Wenn erforderlich lade ich auch mal eine Beispieldatei hoch.
Vielen dank schon mal für die Hilfe.
Gruß Oblivion

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige