Bezug der Formel ändern

Hallo zusammen,
zu Beginn, erstmal ein Danke an die Experten in diesem Forum.
Dank eurer Unterstützung habe ich bisher alles an VBA so hinbekommen, dass meine Liste so funktioniert wie ich sie mir vorstelle.
Nun komme ich allerdings nicht weiter, weswegen ich mich aktiv an euch wenden muss.
Ich habe eine Dokument mit 4 optisch und funktional identischen Listen.
Arbeitsblatt Nr. 1 nennt sich "offene Punkte". Pro Zeile können hier offene Punkte eingegeben werden. In Spalte I erfolgt eine Klassifizierung per Dropdown (3 unterschiedliche Optionen). Nun habe ich einen Makro, der Spalte I ausliest und die Liste entsprechend der Klassifizierung in das richtige andere Arbeitsblatt einfügt und aus der "offenen Punkte"-Liste löscht.
In Spalte O habe ich eine Regel, die ausliest, wenn dieser Punkt länger als 365 Tage nicht mehr geprüft wurde.
Nun zu meinem Problem:
Bei der Ablage in eine "Klassifizierungs"-Tabelle, endet sich der Zellbezug meiner Formel nicht.
Aktuell ist die Formel: =O1-365>M2 , wobei O1 konstant O1 ist und M2 variabel ist. Das funktioniert soweit auch.
Beim Verschieben wird nun aber immer der Zellbezug mitgenommen, d.h. beim Verschieben wird folgende Formel angezeigt: ='Offene Punkte'!O$1-365>$M2
Wie kann ich meinen Makro aufnehmen, dass sich der Teil 'Offene Punkte' aus der Formel löscht?

Sub Ablage()
' Ablage Makro
Dim MarkierteZeile As Long
Dim Formel As Long
Dim Klassifizierung As String
MarkierteZeile = ActiveCell.Row
Klassifizierung = Cells(MarkierteZeile, 9)
Application.Intersect(Selection.EntireRow, Columns("A:O")).Cut
If Klassifizierung = "PVS" Then
Sheets("PVS").Select
Cells(65000, 1).End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Offene Punkte").Select
Application.Intersect(Selection.EntireRow, Columns("A:O")).Delete
End If
If Klassifizierung = "Beschlüsse" Then
Sheets("Beschlüsse").Select
Cells(65000, 1).End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Offene Punkte").Select
Application.Intersect(Selection.EntireRow, Columns("A:O")).Delete
End If
If Klassifizierung = "CIRS" Then
Sheets("Cirs").Select
Cells(65000, 1).End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Offene Punkte").Select
Application.Intersect(Selection.EntireRow, Columns("A:O")).Delete
End If
End Sub

Das hier ist der ganze Code.
Ich würde mich über Rückmeldung sehr freuen. Denke, dass es kein Hexenwerk sein sollte. Ich kriege es aber einfach nicht hin.
1000 Dank und einen schönen Sonntag.
Beste Grüße,
Markus

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Code: [Cc] Sub Ablage() With Application .ScreenUpdating = True .EnableEvents = False .Intersect(Selection.EntireRow, Columns("A:O")).Cut On Error GoTo Fehler With Sheets(Cells(ActiveCell.Row, 9).Value) .Select .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select .Paste .Cells.Replace What:="'Offene Punkte'!", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2 End With Sheets("Offene Punkte").Select .Intersect(Selection.EntireRow, Columns("A:O")).Delete Fehler: .ScreenUpdating = True .EnableEvents = True End With End Sub

Beliebteste Forumthreads (12 Monate)

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread