Private Sub WorksheetChange(ByVal Target As Range

Ich versuche schon seit Tagen mit Hilfe diverser Archivrecherchen meine Aufgabe zu lösen, aber da bin ich halt zu schwach.
Aufgabe (vereinfacht):
ganze Zahl gleich/größer 0 in Spalte "D" löst das Makro aus (Blatt Plan)
Bei Zahl = "0" oder Target (0,2)= "System" End Sub
Bei Zahl gleich/größer 1 : Die Zellen 1 bis 9 rechts des Targets kopieren
wenn die Zahl = 1, dann in letzte Zeile Spalte 1:9 des Blatts "Maßnahmen" einfügen
wenn die Zahl = 2, dann 2 mal untereinander einfügen,
wenn die Zahl = 3, dann 3 mal usw. bis etwa max. 20 mal untereinander.
Mit meinem Gurken VBA und etlichen "wenn" Formeln schaffe ich es fast, wenn auch nicht gerade elegant.
Zwei Dinge klappen nicht:
1) Die Zahl resultiert aus einer Formel, das erkennt mein VBA nicht, es startet nur bei manuellem Eintrag. Habe dann zusätzlich Spalte "D" ohne Formel eingefügt, nur = "B" (B beinhaltet die Formel) hat auch nicht geholfen.
2) Ich kriege nicht raus wie ich die 9 Zellen rechts des Targets zum kopieren aktiviere
Im Voraus vielen Dank
Winfried

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Auweia, jetzt habe ich doch noch ein Problemchen gefunden.
Funktioniert nach Übertrag in die Originaldateien wunderbar- aaaaber,
er kopiert die Formeln und nicht die Werte.
Das konntest Du natürlich nicht bemerken da meine hochgeladene Datei keine Formeln beinhaltete. Hier müsste wohl irgendwo ein "values" rein:
Range(Cells(Target.Row, 5), Cells(Target.Row, 13)).Copy .Range("A" & lgCount + iCount)
Hier nochmals der gesamte Code:


Private Sub Worksheet_Change(ByVal Target As Range)
Dim iCount As Integer
Dim lgCount As Long
'prüfen ob Eingabe in A, B oder K
If Target.Column = 1 Or Target.Column = 2 Or Target.Column = 11 Then
'Spalte A, B und K ausgefüllt?
If Cells(Target.Row, 1) <> "" And Cells(Target.Row, 2) <> "" And Cells(Target.Row, 11) <> "" Then
If Cells(Target.Row, 4) = 0 Then Exit Sub
If Cells(Target.Row, 6) <> "System" Then Exit Sub
'erste freie Zeile in Zielblatt
With Sheets("Maßnahmen")
lgCount = .Range("H65536").End(xlUp).Row
'ermitteln, wie oft geschrieben werden muss
For iCount = 1 To Cells(Target.Row, 4)
'Bereich E bis M kopieren
'Bemerkung: Zellen 5 - 13 beinhalten Formeln, beim Einfügen erscheinen diese an stelle der Werte
Range(Cells(Target.Row, 5), Cells(Target.Row, 13)).Copy .Range("A" & lgCount + iCount)
'und die Nummer schreiben
.Cells(lgCount + iCount, 8) = iCount
Next
End With
End If
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim iCount As Integer Dim lgCount As Long 'prüfen ob Eingabe in A, B oder K If Target.Column = 1 Or Target.Column = 2 Or Target.Column = 11 Then 'Spalte A, B und K ausgefüllt? If Cells(Target.Row, 1) <> "" And Cells(Target.Row, 2) <> "" And Cells(Target.Row, 11) <> "" Then If Cells(Target.Row, 4) = 0 Then Exit Sub If Cells(Target.Row, 6) <> "System" Then Exit Sub 'Bereich E bis M kopieren Range(Cells(Target.Row, 5), Cells(Target.Row, 13)).Copy 'erste freie Zeile in Zielblatt With Sheets("Maßnahmen") lgCount = .Range("H65536").End(xlUp).Row 'ermitteln, wie oft geschrieben werden muss For iCount = 1 To Cells(Target.Row, 4) 'Werte in Zielbereich einfügen .Range("A" & lgCount + iCount).PasteSpecial Paste:=xlValues 'und die Nummer schreiben .Cells(lgCount + iCount, 8) = iCount Next End With Application.CutCopyMode = False End If End If End Sub

Beliebteste Forumthreads (12 Monate)

Private Sub WorksheetChange(ByVal Target As Range

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

309 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Private Sub WorksheetChange(ByVal Target As Range

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

309 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread