Clever-Excel-Forum

Clever-Excel-Forum > Office-Anwendungen > Excel > Zeilen Doppelter Werte nach addieren löschen
Normale Version: Zeilen Doppelter Werte nach addieren löschen
Du siehst gerade eine vereinfachte Darstellung unserer Inhalte. Normale Ansicht mit richtiger Formatierung.
Seiten: 1 2 3 4 5 6

atilla

03.03.2016, 08:27
Hallo Frank,

mit den Nullen ist kein Problem, man bekommt es mit einer IF Abfrage geregelt.

Das hier:


Zitat:...bleibt noch die Hürde mit dem Markieren addierter Zahlenwerte die beide höher Null waren.

verstehe ich nicht ganz.

Wenn Du es so meinst, dass die Zeilen in die aufsummiert wurden, kenntlich gemacht werden, dann lass mal folgenden Code laufen und schau Dir die neue letzte Spalte an.
Diese Spalte nach eins Filtern, dann hast Du die Zeilen.

Die Fehlermeldung kann ich nicht nachvollziehen. Bei mir tritt kein Fehler ein.
Hattest Du den zuletzt eingestellten Code genutzt?

Jetzt teste folgenden Code, tritt der Fehler wieder auf?


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

 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:=.Range("A1"), 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
             .Cells(i, j) = dblS
             .Cells(i, lngS + 1) = 1
           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
 End With

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

GMG-CC

03.03.2016, 09:06
Moin Frank,
danke für die *.xlsx.Bei der Gelegenheit: Gestern Abend hatte ich den zweiten Kunden, der mit Locky Bekanntschaft machte … :22: 

Ich bin heute ziemlich in Zeitnot, darum habe ich den Code nur überflogen. So stümperhaft ist der doch gar nicht! Die Routine kommt von alleine. - Im Anhang eine Auswertung mit Power Query und Pivot, also ohne VBA (obwohl ich VBA-Fan bin). Wenn ich dich richtig verstanden habe, sollte das in etwa so aussehen. Eventuelle Rückfragen wahrscheinlich erst später am heutigen Tage ...

Frank BST

03.03.2016, 10:06
Schon mal Geil

Es läuft super schnell,
keine Nullen zu sehen.

und auch das mit der neuen Spalte und dem Filtern nach der 1 ist ein Ansatz.

Trotz Fehlermeldung:
"Fehler: 9
Index außerhalb des gültigen Bereichs"

Makro läuft zügig durch.


ABER....

Ja leider Aber.

Mögliches Szenario:
[attachment=4414]

Nach lauf deines Makros (mit Fehlermeldung :19:)
[attachment=4413]

Neue Spalte mit Einsen markiert jede bearbeitete Zeile.
Ich benötige aber nur die Zeilen(siehe Bild)
In denen vorhandene Werte addiert wurden.
[attachment=4408]

P.S. kann das Makro mir die neue Spalte mit den Einsen schon aufsteigend sortieren? Blush Angel Blush

Frank BST

03.03.2016, 11:12
Hallo Günther,

dank dir nochmal für die Hinweise und den Einsatz.

Dann kreuze ich mal die Finger,
auf das und Locky uns erspart bleibt.

Vielleicht muss ich mich mal mehr mit Pivot beschäftigen.

Den Vorteil den ich sehe:
Alle Einträge bleiben erhalten.
Ich kann also alle Werte im nachhinein Kontrollieren und Gegenprüfen.

Aber wie befürchtet ist die Tabelle um ein vielfaches größer (KB)
Und schon bei meiner Größe bekommen ich gelegentlich Probleme beim scrollen. (Zeitraffer :22: )

Ich steig da nicht ganz durch Huh
Es kommt mir so unübersichtlich vor.
Und meine Formatierung scheint in der Pivot Anzeige auch einige Abweichungen zu bewirken.
(Zeilen Höhe ist unterschiedlich)

Vielleicht sollte ich mal an einem Pivot Kurs teilnehmen.

WillWissen

03.03.2016, 11:21
Hi Frank,

einen kostenlosen Kurs bekommst du u.a. hier: https://www.youtube.com/watch?v=jpLN5P9zx9A

atilla

03.03.2016, 11:28
Hallo,

dann teste mal so:


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
           If Application.Count(.Range(.Cells(i, j), .Cells(i + .Cells(i, lngS + 2) - 1, j))) > 1 Then
             .Cells(i, j) = Application.WorksheetFunction.Sum(.Range(.Cells(i, j), .Cells(i + .Cells(i, lngS + 2) - 1, j)))
             .Cells(i, lngS + 1) = 1
           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

Frank BST

03.03.2016, 11:31
:28: Danke, schau ich mir nach der Arbeit mal an :28:

Frank BST

03.03.2016, 12:07
mer komme der Lösung immer näher.

Aber Irgendwo ist noch der Wurm drin.

Viele Werte gehen verloren
Es scheint als würden nur Werte addiert mit Zahlen größer Null
Siehe Bild(oben=vorher; unten=nachher)
[attachment=4416]
Die Markierten werte sind in der Summe nicht mehr vorhanden.

&
Die richtigen Zeilen sind nun durch die Einser an den Rand der Tabelle gerutscht,
jedoch kann ich später nicht mehr wissen welcher der vielen Werte in einer Zeile einer Überprüfung bedürfen.
Es müsste also zusätzlich genau jener Wert (In unserem Beispiel die Zweier) irgenwie kenntlich gemacht werden.

Frank BST

03.03.2016, 12:38
Übersichtlicher?
[attachment=4417]

atilla

03.03.2016, 12:44
Hallo,

OK, hab mich ein wenig dusselig angestellt.

So sollte es gehen:


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
Seiten: 1 2 3 4 5 6
Clever-Excel-Forum > Office-Anwendungen > Excel > Zeilen Doppelter Werte nach addieren löschen