AW: Tabellen sortieren
15.01.2006 21:07:12
Peter
Hallo Jürgen,
ich habe die Makros im Tabellenblatt 'Namenliste' ein wenig 'aufgeräumt' und ergänzt.
Ich habe die Namen mit den Nummern 22 bis 29 problemlos eingefügt.
Übernimm die Makros aus dem Tabellenblatt in dein Original, schlage ich vor.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim objSh As Worksheet
Dim objTar As Worksheet
Dim blnExist As Boolean
Dim intNum As Integer
Dim lngLast As Long
Dim rng As Range
On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
If Not Intersect(Target, Range("B5:B1000")) Is Nothing And Target.Count = 1 Then
If Target = "" Then Exit Sub
blnExist = False
intNum = Application.CountA(Range("B5:B1000"))
If Target.Offset(0, -1) = "" Then Target.Offset(0, -1) = intNum
For Each objSh In ThisWorkbook.Worksheets
If objSh.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2) Then
Set objTar = objSh
blnExist = True
Exit For
End If
Next objSh
If Not blnExist Then
Set objTar = Worksheets.Add(after:=Sheets(Sheets.Count))
Sheets("Format").Cells.Copy Destination:=ActiveSheet.Cells
objTar.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2)
ActiveSheet.Cells(6, 1).Value = Cells(Target.Row, 2)
DoEvents
Call Makros_TabBlatt_generieren(objTar.Name)
Me.Activate
End If
End If
If Not Intersect(Target, Range("P5:Q1000")) Is Nothing Then
blnExist = False
For Each objSh In ThisWorkbook.Worksheets
If objSh.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2) Then
Set objTar = objSh
blnExist = True
Exit For
End If
Next objSh
If Not blnExist Then
Set objTar = Worksheets.Add(after:=Sheets(Sheets.Count))
Sheets("Format").Cells.Copy Destination:=ActiveSheet.Cells
objTar.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2)
ActiveSheet.Cells(6, 1).Value = Cells(Target.Row, 2)
DoEvents
Call Makros_TabBlatt_generieren(objTar.Name)
Me.Activate
End If
With objTar
Set rng = .Range("E:E").Find(What:=Cells(Target.Row, 16).Value, _
LookIn:=xlFormulas, lookat:=xlWhole)
If Not rng Is Nothing Then
rng.Offset(0, 1) = Cells(Target.Row, 17)
Else
lngLast = .Cells(Rows.Count, 5).End(xlUp).Row + 1
If lngLast < 6 Then lngLast = 6
.Cells(lngLast, 5) = Cells(Target.Row, 16)
.Cells(lngLast, 6) = Cells(Target.Row, 17)
End If
End With
End If
Set objTar = Nothing
Set rng = Nothing
ErrorHandler:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationManual
.DisplayAlerts = True
End With
End Sub
Viele Grüße Peter
Eine kurze Nachricht, ob es läuft, wäre nett - danke.