AW: Sub Worksheet_Change(ByVal Target As ...
27.02.2023 14:00:12
Haustein
das coding habe ich von piet
Problem ist, dass wenn ich
diesen code aktiv lasse Worksheets("Gesamt").Cells(7, 7) = "Pages 1/" & Anzahl
läuft der code in eine Endlosschleife
wie bekomme ich da gelöst
Sub Worksheet_Change(ByVal Target As Range)
Dim Anzahl As Integer
If Not Intersect(Target, Range("A13:A" & Rows.Count)) Is Nothing Then
If Target.Count > 1 Then Exit Sub
With Worksheets("Gesamt")
On Error GoTo Fehler
If Target.Value = Empty Then
Sht = Mid(Target.Cells(1, 2).Formula, 2)
Sht = Left(Sht, InStr(Sht, "!") - 1)
Sht = Replace(Sht, "'", "")
ok = MsgBox(Sht & vbLf & "Soll diese Tabelle gelöscht werden?", vbYesNo)
If ok = vbNo Then Exit Sub
Application.DisplayAlerts = False
Worksheets(Sht).Delete
Application.DisplayAlerts = True
Target.EntireRow.Delete shift:=xlUp
Exit Sub
End If
On Error Resume Next
NewSht = Target.Value
'Test ob Sheet schon existiert?
Set Test = Worksheets(NewSht)
If Err.Number = 0 Then
MsgBox "Diese Tabelle ist bereits vorhanden!", vbInformation
Target.Select: Exit Sub
End If
Err.Clear 'Löschen!
On Error GoTo Fehler
'Mustersheet kopieren und ausfüllen
Sheets("Musterseite").Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = NewSht
'Artikelname + Einzelpreis setzen
Sheets(NewSht).Range("B1") = Target.Value
'Formeln in Menge + Summe in Gesamt setzen
Target.Offset(0, 1).Formula = "='" & NewSht & "'!F1"
Target.Offset(0, 2).Formula = "='" & NewSht & "'!F2"
'Zelle für Einzelpreis aktivieren
ActiveSheet.Range("B2").Select
End With
End If
Anzahl = ThisWorkbook.Sheets.Count
Worksheets("Gesamt").Cells(7, 7) = "Pages 1/" & Anzahl
a = 1
Exit Sub
Fehler: MsgBox "Unerwarteter Fehler aufgetreten" & vbLf & Error()
End Sub