AW: automatisch sortieren
29.09.2008 17:16:00
oblivion
Hallo, also ich habe noch ein wenig rumgesucht und was gefunden. Jetzt brauche ich nur nochmal Hilfe, wie ich das in meinen bestehenden Code einfüge.
Als erstes den Code den ich mir zusammengesucht und leicht geändert habe:
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
Ich habe den Code ausprobiert und er scheint zu so zu klappen wie ich mir das vorgestellt hatte.
Und hier ist mein bisheriger Code in den ich den neuen noch einfügen muss:
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 hab versucht den kurzen Code an den langen anzuhängen aber da gab es einen Konflikt mit dem Worksheet_Change-Ereignis.
Ich hoffe das man den Code in den bestehenden einfügen kann.
Danke schon mal für die Hilfe.
Gruß Oblivion