Zeilen Doppelter Werte nach addieren löschen

[Frank BST]

Ne is klar

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.

[Frank BST]

...ups, da sind mir wohl noch ein paar Werte entgangen,
so sollte es stimmen.
   
Ich hoffe es wird klar was ich meine

[Frank BST]

...shit, wird Zeit das Feierabend wird.
Dieses Bild meinete ich :s
   

[Rabe]

Mit bedingter Formatierung?
für den Zellbereich $B$5:$BB$21
=B5<>1 oder =B5>1
Zellhintergrund füllen mit Rot

[Frank BST]

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
  
  
   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)).Select
      .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
                     .Cells(i, j) = dblS
                     .Range(.Cells(i, j), .Cells(i + .Cells(i, lngS + 2) - 1, j)).Select
                  End If
               Next j
            End If
         End If
      Next i
      .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)).Select
      .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

[atilla]

Hallo,


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


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

Ende:
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
 If Err Then MsgBox "Fehler: " & Err.Number & vbLf & vbLf & Err.Description
End Sub

[Frank BST]

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.

[Frank BST]

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

Leider ohne Erfolg :s

Wie gehts richtig?

[atilla]

Hallo,

ein wenig mehr Feedback wäre netter.

Das was Du suchst, findest Du in meinem zuletzt eingestellten Code.

Diese Zeile

Code:

.Range(Cells(5, 1), .Cells(lngZ, lngS)).Interior.ColorIndex = xlNone

löscht den Hintergrund, bevor ich ihn Färbe.


so wäre es für Dich möglich:

Code:

Range("B5:ZZ15000").Interior.ColorIndex = xlNone

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

[Frank BST]

Einen Wunderschönen Guten Morgen

Sorry, also hier nochmal Detaillierter 

Hier also die Ursprungsdatei (*.xlsx) mit ca. 200 hinzugefügten Zeilen ab Zeile 4734

  20151202vorher.xlsx (Größe: 115,29 KB / Downloads: 1)

Hier die selbe Datei nach lauf des Makros allerdings noch mit aktiver bedingter Formatierung

  20151202nachher mit BF.xlsx (Größe: 151,58 KB / Downloads: 0)

Hier die selbe Datei nach lauf des Makros jedoch mit zuvor gelöschten bedingten Formatierungen im gesamten Arbeitsblatt

  20151202nachher ohne BF.xlsx (Größe: 151,52 KB / Downloads: 0)

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


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