Einen Wunderschönen Guten Morgen
Sorry, also hier nochmal Detaillierter
Hier also die Ursprungsdatei (*.xlsx) mit ca. 200 hinzugefügten Zeilen ab Zeile 4734
[
attachment=4455]
Hier die selbe Datei nach lauf des Makros allerdings noch mit aktiver bedingter Formatierung
[
attachment=4456]
Hier die selbe Datei nach lauf des Makros jedoch mit zuvor gelöschten bedingten Formatierungen im gesamten Arbeitsblatt
[
attachment=4457]
Ich sehe keinen Unterschied zwischen mit und ohne bedingter Formatierung.
Bisher ist die Tabelle in dieser Form manuell gewachsen, wofür ich die Formatierung nutzte.
Wenn das Makro erstmal läuft ist die bedingte Formatierung nutzlos und wird entfernt.
Wie man an der Anzahl der Zeilen erkennt wurden keine Zeilen gelöscht. (Obwohl die Mehrzahl der Werte in Spalte A bereits vorhanden waren)
Die neu hinzugefügten Zeilen mit den Doppelten Werten erhielten jedoch wie gewollt in der Spalte 'CP' eine 0
Wenn ich selbes Makro in der *.xlsm Datei laufen lasse, in der es auch gespeichert ist, funktioniert alles.
Der
Unterschied ist jedoch, dass die neu hinzugefügte Spalte sich innerhalb der Tabelle befindet.
Bei der *.xlsx Datei jedoch entsteht Spalte 'CP' ausserhalb der Tabelle.
Auch stehen nach der Sortierung in der neuen Spalte bei der *.xlsm nur Werte.
Bei der *.xlsx verbleibt es in der neuen Spalte noch bei der Formel '=WENN'
In allen Varianten tritt der Fehler 9 auf.
[
attachment=4459]
Nach dem Makrolauf und dem Fehler 9 kann in der *.xlsx Datei augenblicklich gearbeitet werden.
Nach dem Makrolauf und dem Fehler 9 kann in der *.xlsm Datei ist Excel für weitere Sekunden eingefroren.
Dann jedoch ist es in der *.xlsm das gewünschte Ergebnis.
Hier nochmal der benutzte Code:
Code:
Option Explicit
Sub Löschen()
Dim i As Long, j As Long
Dim lngS As Long ' die letzte belegte Spalte in Zeile 4
Dim lngZ As Long ' die letzte belegte Zeile in Spalte A
Dim dblS As Double
Dim rngA As Range
On Error GoTo Ende
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("Tabelle1")
lngZ = .Cells(Rows.Count, 1).End(xlUp).Row
lngS = .Cells(4, Columns.Count).End(xlToLeft).Column
.Range(.Cells(4, 1), .Cells(lngZ, lngS)).Sort _
Key1:=.Cells(4, 1), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
.Range(.Cells(5, lngS + 2), .Cells(lngZ, lngS + 2)).FormulaLocal = "=Wenn(A5<>A4;ZÄHLENWENN(A:A;A5);0)"
For i = 5 To lngZ
If Cells(i, lngS + 2) > 1 Then
If .Cells(i, 1) = .Cells(i + 1, 1) Then
For j = 2 To lngS
dblS = Application.WorksheetFunction.Sum(.Range(.Cells(i, j), .Cells(i + .Cells(i, lngS + 2) - 1, j)))
If dblS > 0 Then
If Application.Count(.Range(.Cells(i, j), .Cells(i + .Cells(i, lngS + 2) - 1, j))) > 1 Then
.Cells(i, lngS + 1) = 1
If rngA Is Nothing Then
Set rngA = .Cells(i, j)
Else
Set rngA = Union(rngA, .Cells(i, j))
End If
End If
.Cells(i, j) = dblS
End If
Next j
End If
End If
Next i
.Range(Cells(5, 1), .Cells(lngZ, lngS)).Interior.ColorIndex = xlNone
If Not rngA Is Nothing Then
rngA.Interior.ColorIndex = 3
Set rngA = Nothing
End If
.Range(Cells(4, 1), .Cells(lngZ, lngS)).RemoveDuplicates Columns:=1, Header:=xlYes
.Columns(lngS + 2).Clear
lngZ = .Cells(Rows.Count, 1).End(xlUp).Row
lngS = .Cells(4, Columns.Count).End(xlToLeft).Column
.Range(.Cells(4, 1), .Cells(lngZ, lngS)).Sort _
Key1:=.Cells(4, lngS), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
Ende:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
If Err Then MsgBox "Fehler: " & Err.Number & vbLf & vbLf & Err.Description
End Sub