Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1096to1100
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

doppelte löschen

doppelte löschen
walter
Hallo und guten Abend,
Josef hatte mir freundlicherweise die anhängende Geschichte zurechtprogrammiert, die allerdings leider noch etwas abweicht.
Es sollen die verkrüppelten Sätze (Spalte a nur bis zum Bindestrich gehende) Sätze in das Nebenblatt verschoben werden (dies klappt bestens).
Zusättzlich sollen aber alle doppelten Sätze, gekennzeichnet durch Spalte A, mit Ausnahme desjenigen mit den niedrigsten Werten in Spalten 1-3, gelöscht werden. Hier müßte noch einmal ein Wissender drüberblicken, da nicht alle doppelten gelöscht werden.
Könnte in diesem Zuge das Makro so erweitert werden, das auch die hier nicht dargestellten Spalten (bis AQ) ebenfalls mit verschoben oder gelöscht werden ?
mit Dank im Voraus
Gruß
Walter
https://www.herber.de/bbs/user/64122.xls
PS: sollte der Beitrag hier jetzt doch noch doppelt erscheinen, so sorry, System war abgeschmiert

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: doppelte löschen
30.08.2009 21:55:19
Josef
Hallo Walter,
so sollte es klappen.
Sub fehlendeFS()
  Dim rng As Range, rngData As Range, rngCopy As Range
  
  On Error GoTo ErrExit
  Application.ScreenUpdating = False
  
  Set rngData = Range("A3:A" & Application.Max(3, Cells(Rows.Count, 1).End(xlUp).Row))
  
  For Each rng In rngData
    If rng Like "*-" Then
      If rngCopy Is Nothing Then
        Set rngCopy = rng.Resize(1, 5)
      Else
        Set rngCopy = Union(rngCopy, rng.Resize(1, 5))
      End If
    End If
  Next
  
  If Not rngCopy Is Nothing Then
    rngCopy.Copy Sheets("fehlende FS Nr").Range("A2")
    rngCopy.EntireRow.Delete
  End If
  
  Set rngCopy = Nothing
  
  Columns("A:B").Insert
  Range("A3").Formula = "=SUM(E3:G3)+ROW()/1000000"
  rngData.Offset(0, -2).FillDown
  Range("B3").FormulaArray = "=IF(COUNTIF($C$3:$C$28,C3)>1,IF(SUM(E3:G3)+ROW()/1000000=MIN(IF($C$3:$C$28=C3,$A$3:$A$28)),"""",""x""),"""")"
  rngData.Offset(0, -1).FillDown
  
  For Each rng In rngData.Offset(0, -1)
    If rng = "x" Then
      If rngCopy Is Nothing Then
        Set rngCopy = rng
      Else
        Set rngCopy = Union(rngCopy, rng)
      End If
    End If
  Next
  
  If Not rngCopy Is Nothing Then rngCopy.EntireRow.Delete
  
  Columns("A:B").Delete
  
  ErrExit:
  With Err
    If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
      .Description & vbLf & vbLf & "In Prozedur (fehlendeFS) in Modul Modul1", _
      vbExclamation, "Fehler in Modul1 / fehlendeFS"
  End With
  
  Application.ScreenUpdating = True
  
  Set rng = Nothing
  Set rngData = Nothing
  Set rngCopy = Nothing
End Sub

Gruß Sepp

Anzeige
AW: doppelte löschen
31.08.2009 10:56:23
walter
Hallo Sepp,
vielen Dank für Deine erneute Hilfe. Eben wurde mir der Fehler klar, er liegt bei mir, bisher sprach ich nur von davon den niedrigsten Eintrag eines keys stehenzulassen. Leider habe ich nicht soweit mitgedacht, daß er bei gleichen Keys und gleichen Werten, den Satz nur einmal stehenlassen soll. Die doppelten hinfort.
Kleinlaut: nochmal die Bitte...
Gruß
Walter
AW: doppelte löschen
31.08.2009 18:25:24
Josef
Hallo Walter,
aber genau das macht mein Code!
Hast du es wenigstens mal in deiner Beispieldatei getestet?
Gruß Sepp

Anzeige
AW: doppelte löschen
31.08.2009 21:20:47
walter
Hallo Sepp,
sorry für die Irritation, habe wohl zu viel getestet...... :-((( mein Fehler.
In der Testdatei klappt es reibungslos, keine doppelten Datensätze mehr enthalten (alles läuft wie gewünscht).
Allerdings in der Originaldatei, kann ich leider nicht rausgeben da vertrauliche Daten, bleiben mir einige Doppelte erhalten.
Nochmals vielen Dank, werde dann dieser Tage ausgeschlafen mich der Sache nochmals annehmen und die kompletten Zeilen auf Abweichungen untersuchen, evtl. liegt hier der (mein) Bock.
Gruß
Walter
AW: doppelte löschen
31.08.2009 21:27:22
Josef
Hallo Walter,
kopiere doch nur die Spalte mit den Hauptkeys in ein neues Tabellenblatt und lade es hoch, dann werden wir den Hund schon finden, so den da einer vergraben ist;-))
Gruß Sepp

Anzeige
AW: doppelte löschen
01.09.2009 23:21:38
walter
Hallo Sepp,
nochmals mit Dank für die tröstenden Worte :-))) und Dein Angebot der Lösungssuche
in anliegender Datei ist der komplette Datensatz, alle Spalten mit Überschrift sind normalerweise gefüllt (aber hier irrelevant).
Wichtig: Spalten a-e sind Berechnungen
Dein Makro (letztes update ist enthalten). Bestens klappt es mit der Aussortierung der verkrüppelten keys. Jedoch bitte auch noch die restlichen Spalten mit ins zweite Blatt mitnehmen.
Im Originalblatt soll dann bei den doppelten keys immer derjenige mit den niedrigsten Beträgen (Summe aus c:e) erhalten bleiben. Die anderen ins Tönnchen. Sind mehrere gleiche keys mit Nuller beträgen, darf hier ebenfalls dieser key nur einfach stehenbleiben.
Nochmals mit Dank + Gruß
Walter
https://www.herber.de/bbs/user/64165.xls
Anzeige
AW: doppelte löschen
01.09.2009 23:35:35
Josef
Hallo Walter,
der Fehler lag nicht in deinen Daten sondern an meiner Blödheit;-(((
Hatte übersehen, das ich in den Formeln die Adresse(n) fest eingetragen, und nicht dynamisch an den Datenbereich angepasst habe.
So läuft es.
Sub fehlendeFS_neu()
  Dim rng As Range, rngData As Range, rngCopy As Range
  
  On Error GoTo ErrExit
  Application.ScreenUpdating = False
  
  Set rngData = Range("A3:A" & Application.Max(3, Cells(Rows.Count, 1).End(xlUp).Row))
  
  For Each rng In rngData
    If rng Like "*-" Then
      If rngCopy Is Nothing Then
        Set rngCopy = rng
      Else
        Set rngCopy = Union(rngCopy, rng)
      End If
    End If
  Next
  
  If Not rngCopy Is Nothing Then
    rngCopy.EntireRow.Copy Sheets("fehlende FS Nr").Range("A2")
    rngCopy.EntireRow.Delete
  End If
  
  Set rngCopy = Nothing
  
  Columns("A:B").Insert
  Range("A3").Formula = "=SUM(E3:G3)+ROW()/1000000"
  rngData.Offset(0, -2).FillDown
  Range("B3").FormulaArray = "=IF(COUNTIF(" & rngData.Address & ",C3)>1,IF(SUM(E3:G3)+ROW()/1000000=MIN(IF(" & rngData.Address & "=C3," & rngData.Offset(0, -2).Address & ")),"""",""x""),"""")"
  rngData.Offset(0, -1).FillDown
  
  For Each rng In rngData.Offset(0, -1)
    If rng = "x" Then
      If rngCopy Is Nothing Then
        Set rngCopy = rng
      Else
        Set rngCopy = Union(rngCopy, rng)
      End If
    End If
  Next
  
  If Not rngCopy Is Nothing Then rngCopy.EntireRow.Delete
  
  Columns("A:B").Delete
  
  ErrExit:
  With Err
    If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
      .Description & vbLf & vbLf & "In Prozedur (fehlendeFS) in Modul Modul1", _
      vbExclamation, "Fehler in Modul1 / fehlendeFS"
  End With
  
  Application.ScreenUpdating = True
  
  Set rng = Nothing
  Set rngData = Nothing
  Set rngCopy = Nothing
End Sub

Gruß Sepp

Anzeige
AW: doppelte löschen
02.09.2009 00:04:21
walter
Hallo Sepp,
suuuuuper, vielen Dank, sieht sehr gut aus. Der Aufwand hat sich gelohnt.
Gruß
Walter

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige