VBA-Code: |
Private Sub Worksheet_Change(ByVal Target As Range) 'Code in das entsprechende Tabellenblatt! If Range("E4") "" Then ActiveSheet.Name = Target.Value End Sub Gruß Jürgen |
VBA-Code: |
Private Sub Worksheet_Change(ByVal Target As Range) 'Code in das entsprechende Tabellenblatt! If Len(Range("E4")) < 32 And Range("E4") <> "" Then ActiveSheet.Name = Range("E4").Value End If End Sub Gruß Jürgen |
VBA-Code: |
Private Sub Worksheet_Change(ByVal Target As Range) 'Code in das entsprechende Tabellenblatt! If Len(Range("E4")) < 32 And Range("E4") <> "" Then If Sheets(Sheets.Count).Name <> Range("E4").Value Then ActiveSheet.Copy After:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = Range("E4") End If End If End Sub Gruß Jürgen |
'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
' 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