Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1532to1536
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
Zeilen löschen wenn...
10.01.2017 11:42:33
Al
Hallo zusammen,
ich habe eine Liste und würde gerne die doppelten Einträge löschen nach folgender Regel:
Wenn die Werte in den Spalten D, E, F und H der jeweiligen Zeile die gleichen sind, dann lösche die doppelte Zeile. Hierbei müssen die doppelten Zeilen nicht zwangsläufig untereinander sondern irgendwo auf dem Blatt aufgelistet sein.
Hierfür habe ich ein Makro zusammengestellt, das leider nicht so will wie ich...
Hat jemand eine Idee?
Gruß
Sub DoppelteZeilenLoeschen()
Dim letzteZeile As Long
Dim Zeile As Long
letzteZeile = Range("A65536").End(xlUp).Row
For Zeile = letzteZeile To 1 Step -1
If WorksheetFunction.CountIf(Range("D:H" & Zeile), Cells(Zeile, 1)) > 1 Then
Cells(Zeile, 1).EntireRow.Delete
End If
Next
End Sub

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zeilen löschen wenn...
10.01.2017 12:55:57
UweD
Hallo
so?
Sub DoppelteZeilenLoeschen()

  Dim lZ As Long
  Dim Z As Long

  lZ = Range("A65536").End(xlUp).Row

  For Z = lZ To 1 Step -1
    If WorksheetFunction.CountIfs(Range("D1:D" & lZ), Range("D" & Z), _
            Range("E1:E" & lZ), Range("E" & Z), Range("F1:F" & lZ), Range("F" & Z), _
            Range("H1:H" & lZ), Range("H" & Z)) > 1 Then
        Rows(Z).Delete xlUp
    End If
  Next

End Sub
LG UweD
Anzeige
AW: Zeilen löschen wenn...
10.01.2017 13:00:22
Anton
Hallo AI,
hab auch noch eine Lösung. Funktioniert zumindest bei mir :) Glaub aber UweD's Lösung ist um weiten eleganter.
Sub DoppelteZeilenLöschen()
Dim rngBereich As Range
Dim rngZelle As Range
Dim wksBlatt As Worksheet
Set wksBlatt = ThisWorkbook.Worksheets("Tabelle3") 'Tabelle anpassen
With wksBlatt
Set rngBereich = .Range("A1:C" & .UsedRange.Rows.Count)
For Each rngZelle In rngBereich
If Application.WorksheetFunction.CountIf(rngBereich, rngZelle.Value) > 1 Then
rngZelle.Rows.Delete
End If
Next rngZelle
End With
End Sub
VG Anton
Anzeige
Alternativ...
10.01.2017 13:20:52
Michael
Hallo Anton (Hallo Uwe),
...ließe sich das evtl. auch ohne Schleife bewerkstelligen:
Sub ZeilenEntfernenNachKriterien()
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim Ws As Worksheet: Set Ws = Wb.ActiveSheet
Dim Liste As Range, DelListe As Range
Application.ScreenUpdating = False
With Ws
Set Liste = .Range("A1").CurrentRegion
Set DelListe = Liste.Resize(Liste.Rows.Count, Liste.Columns.Count + 1)
With DelListe
.Offset(0, .Columns.Count - 1).Resize(1, 1) = 0
.Offset(1, .Columns.Count - 1).Resize(.Rows.Count - 1, _
1).FormulaLocal = "=WENN(UND(D2=E2;D2=F2;D2=H2);0;ZEILE())"
.RemoveDuplicates Columns:=.Columns.Count, Header:=xlNo
.Offset(0, .Columns.Count - 1).Resize(.Rows.Count, 1).ClearContents
End With
End With
End Sub
Bsp.: https://www.herber.de/bbs/user/110439.xlsm
In meiner Variante jetzt ohne Zählenwenn, und unter Annahme, dass der Datenbereich in A1 beginnt und eine intakte Tabelle (ohne vollständige Leerzeilen/Leerspalten) darstellt.
LG
Michael
Anzeige
AW: Alternativ...
10.01.2017 13:47:57
UweD
hallo nochmal
ich bin von folgendem Aufbau ausgegangen..
Die Zellen innerhalb der Zeile können unterschiedlich sein...

Tabelle1
 ABCDEFGH
1Zähler  AAAABfgsds
2Zähler  AAAABBBfgsds
3Zähler  BBABBBfgsds
4Zähler  BBABBBfgsds
5Zähler  AAAABBBfgsds
6Zähler  AAAAsssasfgsds
7Zähler       
8Zähler       
9Zähler  AAAAwwwrrsds
10Zähler  BBABBBfgsds

LG UweD
Anzeige
AW: Alternativ...
10.01.2017 13:50:25
Al
Also die Farbe ist immer gleich (schwarz). Es ging mir hauptsächlich um die Werte in den Zellen und ich habe dein Makro getestet und ich konnte keinen Fehler entdecken.
Gruß
Dafür ist das ja auch (D)eine Top-Lösung...
10.01.2017 14:08:57
Michael
Uwe,
...mir war nur dieser Aufbau noch nicht klar, und wollte diese Variante nicht untergehen lassen.
LG und schönen Tag
Michael
AW: Zeilen löschen wenn...
10.01.2017 13:46:02
Al
Das klappt super, vielen Dank euch allen für die schnelle Hilfe.
Ich habe mal eine Frage: Ich lade über einen Makro aus diversen Ordnern Daten aus sehr vielen Excelblättern in eine andere Exceldatei. Nach einem gewissen Zeitraum muss ich erneut schauen, ob in diesen Ordnern neue Exceldateien mit entsprechenden Daten enthalten sind. Momentan, so wie mein Makro arbeitet, werden allerdings alle Daten (sowohl aus neuen als auch alten Excelblättern) erneut geladen. D.h. dass alte Daten erneut in die Liste geschrieben werden (daher auch die doppelt vorkommenden Zeilen) und ich mit dem Makro "DoppelteZeilenLoeschen" diese wieder entfernen muss.
Fällt jemanden eine elegantere Lösung ein, damit die alten nicht erneut geladen werden? Oder vielleicht kann man das Makro DoppelteZeilenLoeschen direkt in das angehängte Makro integrieren? Ich frage aus dem einfachen Grunde, weil das Laden der Daten aus den Verzeichnissen mit Unterverzeichnissen... relativ lange dauert.
Danke für eure Hilfe.
Option Explicit
Dim fso As FileSystemObject
Dim zeileZ As Long
Dim wsZ As Worksheet 'Zielblatt
Sub DatenAuslesen_mit_Unterverz()
Dim ergebnis As Long
Dim fd As FileDialog
Dim fol As Folder
Dim letzteZeileZ As Long
Dim pfad As String
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.InitialFileName = ThisWorkbook.Path & "\"
ergebnis = fd.Show
If ergebnis = 0 Then                                                  'Vorgang bei Abbruch
'    MsgBox Prompt:="Abbruch durch den Benutzer"
Exit Sub
End If
pfad = fd.SelectedItems(1)
Set fso = New FileSystemObject
Set fol = fso.GetFolder(pfad)
Set wsZ = ThisWorkbook.Worksheets("Datenauslese")
letzteZeileZ = wsZ.Cells(wsZ.Rows.Count, "A").End(xlUp).Row
zeileZ = letzteZeileZ + 1
Folder_abarbeiten Verzeichnis:=fol
Set fso = Nothing
End Sub

Sub Folder_abarbeiten(Verzeichnis As Folder)
Dim fil As File
Dim fol As Folder
Dim pos As Long
Dim suchErgebnis As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim zeichNr As String
Dim zeileStahlgewicht As Long
For Each fil In Verzeichnis.Files
If fil.Name Like "*.xls*" Then                                      'nur xls Dateien  _
oeffnen
pos = InStrRev(fil.Name, ".")
zeichNr = Left$(fil.Name, pos - 1)                                'Zeichnungsnr aus  _
Dateiname
If Len(zeichNr) 

Anzeige

312 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige