Was du in 3 Minuten korrigiert und gepostet hast,
hätt ich in Tagen nicht rausgefiltert.
Von der Funktion und Geschwindigkeit einfach nur Perfekt, Danke
Vielleicht noch jemand ne Idee wie ich die einzelnen veränderten Werte markieren kann?
Die von mir farblich grün markierten Werte auf dem Foto sind OK
Nur die roten Werte muss ich einer Überprüfung unterziehen.
Wie erfahre ich also in einer längeren Zeile welchen Wert ich Prüfen muss und welchen nicht.
03.03.2016, 14:00 (Dieser Beitrag wurde zuletzt bearbeitet: 07.03.2016, 13:05 von Rabe.
Bearbeitungsgrund: Code-Tags gesetzt
)
Coole Idee
würd ich nehmen.
Wenn Du es mir jetzt noch in diesen CODE einpflegen könntest.
Code:
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
On Error GoTo Ende
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
bloß keine Bedingte Formatierung mehr!!!
Wenn möglich lösch alle bedingten Formatierungen in der Tabelle.
Dann teste weiter
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
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
Ende:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
If Err Then MsgBox "Fehler: " & Err.Number & vbLf & vbLf & Err.Description
End Sub
Erste Tests an einer Kopie meines Original Datensatzes lassen mich verzweifeln.
Kann man in einer *.xlsx keine Makros laufen lassen?
So bin ich vorgegangen:
*.xlsm mit integriertem Makro geöffnet.
Original Datensatz.xlsx geöffnet
In aktiver *xlsx Datei unter Ansicht auf Makros geklickt.
Nun das Makro ausgewählt und für diese Arbeitsmappe ausgeführt.
Das Ergebnis ist jedoch ein völlig anderes.
Keine doppelten Zeilen werden gelöscht
Nichts wird addiert.
Die neue Spalte die erzeugt wird über alle ca. 5000 befüllten Zeilen mit der Formel:
=WENN(A4587<>A4586;ZÄHLENWENN(A:A;A4587);0) befüllt.
Beziehungsweise sind niedrige Zahlen zu sehen, meist 1.
04.03.2016, 13:36 (Dieser Beitrag wurde zuletzt bearbeitet: 07.03.2016, 13:06 von Rabe.
Bearbeitungsgrund: Code-Tags gesetzt
)
Ein weiteres Makro soll die rot befüllten Zellen wieder neutralisieren.
Mit der Makro Aufzeichnung kam folgender Code raus:
Sub Markierungrückgaengig()
'
' Markierungrückgaengig Makro
'
Range("B5:ZZ15000").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
Es funktioniert, ist aber langsam.
Auch der Markierte Bereich ist fix. :s
Ich habe versucht ihn wie folgt zu pimpen:
Code:
Option Explicit
Sub Löschen()
Sub Markierungrueckgaengig()
'
' Markierungrückgaengig Makro
'
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
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
Aber Du hast ja eine Inteligente Tabelle, diese hat auch einen Namen.
Man kann den Bereich auch über den Tabellennamen ansprechen.
Welchen Namen Deine Tabelle hat, siehst Du, wenn Du eine Zelle innerhalb der Tabelle auswählst, dann in der Menüleiste in der neuen Gruppe Entwurf ganz Links
ist der Tabellenname angegeben.
Bisher hieß er in der Beispielmappe Tabelle5
Dann müsste der Code so aussehen:
Code:
Range("Tabelle5").Interior.ColorIndex=xlnone
als Prozedur:
Code:
Sub hintergrundfarbe_weg()
Range("Tabelle5").Interior.ColorIndex = xlNone
End Sub
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.
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
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
