Tabellenblatt automatisch beschriften

oblivion · 2008-08-15T19:20:00+00:00

Hallo, ich habe eine Frage. Gibt es eine Möglichkeit das Tabellenblatt automisch beschriften zu lassen, wenn man sagen wir in E4 einen Namen oder was anderes schreibt? Danke schon mal für eure Hilfe. Gruß Oblivion

Hi Jürgen,
Vorsicht - dein Code tut mehr als du beschrieben hast.
Er wird mit der Mustertabelle kopiert, steht dann x-fach in der Mappe läuft auch in jeder Kopie.
Er rennt nicht nur dann los, wenn sich in E4 etwas ändert, sondern bei Änderung jeder Zelle.
Wenn in E4 der Neme eines nichtletzten Blatts geschrieben wird, greift die Prüfung
If Sheets(Sheets.Count).Name <> Range("E4").Value Then
nicht und es gibt einen Laufzeitfehler.
In E4 kann eine Zahl stehen. Das gibt dann auch Ärger.
Mein Vorschlag:


'Code in "DieseArbeitsmappe"
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim lngI As Long
If Sh.Name  "Muster" Then Exit Sub
If Target.Address  "$E$4" Then Exit Sub
If Len(Target)  "" Then
For lngI = 1 To Sheets.Count
If Sheets(lngI).Name = "" & Target Then
MsgBox "Das Blatt " & Target & " gibt es schon!"
Exit Sub
End If
Next lngI
Sheets("Muster").Copy After:=Sheets(lngI - 1)
ActiveSheet.Name = Target
End If
End Sub

Hier könnte/sollte/müsste man noch prüfen, ob E4.Value ein gültiger Blattname ist.
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Hi Tino,
anstelle von Selection.Count könnte man besser Target.Count prüfen, muss man aber gar nicht.
Die Verarbeitung von ein- und die von mehrzelligen Änderungen braucht man nicht getrennt zu programmieren.
Nebenbei: Wenn für C=1 das zutrifft:
Intersect(Selection(C), Range("E5:G56", "B5:B56")) Is Nothing Then Exit Sub
dann wird der Rest der Selection überhaupt nicht mehr geprüft.
IMHO kann man den bisherigen Codeteil austauschen durch einen erheblich kürzeren.
(Oben muss dafür noch "rngZ As Range" deklariert werden.):


' bisher:
On Error GoTo Fehler:
MsgBox Selection.Address
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:
' neu:
On Error GoTo Fehler:
If Intersect(Target, Range("E5:G56", "B5:B56")) Is Nothing Then Exit Sub
B = Tabelle2.Rows(2).Find(What:=Range("B3"), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Column - 2
AnzeigeAn
For Each rngZ In Intersect(Target, Range("E5:G56", "B5:B56"))
For A = 0 To 5
If A  3 Then
If A = 5 Then
Tabelle2.Cells(rngZ.Row - 1, B - 1) = Cells(rngZ.Row, 2).Value
Else
Debug.Print Cells(rngZ.Row, 3 + A)
Tabelle2.Cells(rngZ.Row - 1, B + A).Value = _
Cells(rngZ.Row, 3 + A).Value
End If
End If
Next A
Next rngZ
Fehler:

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Tabellenblatt automatisch beschriften

Forumthread: Tabellenblatt automatisch beschriften

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial