Microsoft Excel

Herbers Excel/VBA-Archiv

Hallo Erich G.; erweiterte Prüfung

Betrifft: Hallo Erich G.; erweiterte Prüfung von: Lammi
Geschrieben am: 13.08.2014 17:54:48

Hallo zusammen,

vielen Dank Erich g. und Daniel.

..nach einigen Test habe ich festellen müssen, dass ich noch eine Erweiterung des Makros benötige.

Sub SelektivLoeschen2()
   Dim arLR, arLC, arQ, rr As Long, cc As Long, ii As Long, rngR As Range, rngC As Range
   
   With Sheets("Daten_bereinigen")
     arLR = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row)
     arLC = .Cells(1, 2).Resize(.Cells(.Rows.Count, 2).End(xlUp).Row)
   End With

   With ActiveSheet                          ' Sheets("Daten")
      arQ = .Cells(1, 1).CurrentRegion
      For rr = 1 To UBound(arQ)
         For cc = 1 To UBound(arQ, 2)
            If IsArray(arLR) Then
               For ii = 2 To UBound(arLR)
                  If Not IsEmpty(arLR(ii, 1)) Then
                     If arQ(rr, cc) = arLR(ii, 1) Then
                        If rngR Is Nothing Then
                           Set rngR = .Rows(rr)
                        Else
                           Set rngR = Union(rngR, .Rows(rr))
                        End If
                     End If
                  End If
               Next ii
            End If
            If IsArray(arLC) Then
               For ii = 2 To UBound(arLC)
                  If Not IsEmpty(arLC(ii, 1)) Then
                     If arQ(rr, cc) = arLC(ii, 1) Then
                        If rngC Is Nothing Then
                           Set rngC = .Columns(cc)
                        Else
                           Set rngC = Union(rngC, .Columns(cc))
                        End If
                     End If
                  End If
               Next ii
            End If
         Next cc
      Next rr
   End With
   If Not rngR Is Nothing Then rngR.Delete
   If Not rngC Is Nothing Then rngC.Delete
End Sub


Neu:
Nach der Abarbeitung des Makro's 1 soll eine weitere Prüfung duchgeführt werden.
Zeilenprüfung:
Es sollen alle Zeilen gelöscht werden die unvollständig sind.
Anzahl der gefüllten Kopfzeile (A1-...) ≠ Anzahl der Daten
Zeile 5 und Zeile 16 enhalten weniger gefüllte Zellen wie Zeile 1.
Diese sollen gelöscht werden.

Es werden alle Zeilen mit der nachfolgenden Bedingung verbleiben.
Anzahl der Kopfzeilen = Anzahl der gefüllten Datenzellen.

Die Beispieldatei habe ich angepasst.
https://www.herber.de/bbs/user/92081.xlsx
Gruß
Lammi

  

Betrifft: VBA - Zeilen selektiv löschen von: Erich G.
Geschrieben am: 13.08.2014 18:39:44

Hi Lammi,
wegen dieser Zusatzfrage hätte es wohl keines neuen Threads bedurft, die Frage hättest du auch gleich in
Daten_bereinigen von Lammi vom 10.08.2014 07:20:08
stellen können.

Hier der neue Code (unter "--- neu"):

Sub SelektivLoeschen3()
   Dim arLR, arLC, arQ, rr As Long, cc As Long, ii As Long, rngR As Range, rngC As Range
   
   With Sheets("Daten_bereinigen")
     arLR = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row)
     arLC = .Cells(1, 2).Resize(.Cells(.Rows.Count, 2).End(xlUp).Row)
   End With

   With ActiveSheet                    ' Sheets("Daten")
      arQ = .Cells(1, 1).CurrentRegion
      For rr = 1 To UBound(arQ)
         For cc = 1 To UBound(arQ, 2)
            If IsArray(arLR) Then
               For ii = 2 To UBound(arLR)
                  If Not IsEmpty(arLR(ii, 1)) Then
                     If arQ(rr, cc) = arLR(ii, 1) Then
                        If rngR Is Nothing Then
                           Set rngR = .Rows(rr)
                        Else
                           Set rngR = Union(rngR, .Rows(rr))
                        End If
                     End If
                  End If
               Next ii
            End If
            ' ------------------------------------------------------------- neu
            If IsEmpty(arQ(rr, cc)) Then  ' auch Zeilen, in dene eine leere
               If rngR Is Nothing Then    '    Zelle steht, werden gelöscht
                  Set rngR = .Rows(rr)
               Else
                  Set rngR = Union(rngR, .Rows(rr))
               End If
            End If
            ' -------------------------------------------------------------
            If IsArray(arLC) Then
               For ii = 2 To UBound(arLC)
                  If Not IsEmpty(arLC(ii, 1)) Then
                     If arQ(rr, cc) = arLC(ii, 1) Then
                        If rngC Is Nothing Then
                           Set rngC = .Columns(cc)
                        Else
                           Set rngC = Union(rngC, .Columns(cc))
                        End If
                     End If
                  End If
               Next ii
            End If
         Next cc
      Next rr
   End With
   If Not rngR Is Nothing Then rngR.Delete
   If Not rngC Is Nothing Then rngC.Delete
End Sub
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich


  

Betrifft: AW: VBA - Zeilen selektiv löschen von: Lammi
Geschrieben am: 14.08.2014 09:12:28

Hallo Erich,

das Makro läuft durch, löscht aber fast alle Zeilen.
Ich vermute das die Reihenfolge der Abarbeitung das Problem sein könnte.

Das SelektivLoeschen2 läuft.

Ich bin der Meineung dass das Makro 2 erst die Tabelle abarbeiten muss um dann nachgeschaltet die letzte Bedingung zu prüfen.
Es gibt Tabellen in dem die Spalten nur eine Kopfzeile beinhaltet und die restlichen Zeilen keinen Inhalt haben. Diese, so vermutet ich, verursachen dann wohl das alle anderen Datenzeilen gelöscht werden.

Deshalb meine ich, dass das Makro2 durchlaufen sollte wie es ist und erst dann die ditte Abfrage gestratet werden sollte.

Könntest Du das Makro umstellen oder ggf. auch trennen?


Gruß
Lammi




  

Betrifft: Aufgabe unklar von: Erich G.
Geschrieben am: 14.08.2014 10:08:00

Hi,
nun verstehe ich nicht mehr, was du möchtest und was jetzt falsch läuft.

Oben hast du geschrieben:
Es sollen alle Zeilen gelöscht werden die unvollständig sind.
Anzahl der gefüllten Kopfzeile (A1-...) ≠ Anzahl der Daten

und
Es werden alle Zeilen mit der nachfolgenden Bedingung verbleiben.
Anzahl der Kopfzeilen = Anzahl der gefüllten Datenzellen.


Nn schreibst du von
Tabellen in dem die Spalten nur eine Kopfzeile beinhaltet und die restlichen Zeilen keinen Inhalt haben.
Damit wird doch die obige Bedingung erfüllt - die Anzahl Daten ist 0 und damit kleiner als die Anzahl der Kopfzellen -
und das führt zur Löschung der jeweiligen Zeile.

Oder meintest du das anders?

Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich


  

Betrifft: BeiSpielMappe von: Erich G.
Geschrieben am: 14.08.2014 10:53:47

Hi,
vielleicht kann diese Mappe zur Klärung beitragen. Die rot markierten Zeilen/Spalten werden gelöscht,
weil gelb bzw. braun gefunden werden oder die blauen Zellen leer sind.
https://www.herber.de/bbs/user/92096.xlsm

Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich


  

Betrifft: AW: BeiSpielMappe von: Lammi
Geschrieben am: 14.08.2014 12:08:01

Hallo Erich,

ich habe nochmal eine Beispeildatei erzeugt.
https://www.herber.de/bbs/user/92101.xlsm

Hier wird deutlich wenn das Makro3 gesartet wird ergibt es ein anders Ergebnis als wenn ich erst das Makro 2 und dann das Makro3 starte.

wie geschrieben ich benötige eine bestimmte Reihenfolge.

Gruß
Lammi


  

Betrifft: neue Version von: Erich G.
Geschrieben am: 14.08.2014 13:08:40

Hi,
jetzt habe ich es wohl verstanden... -):

Wenn eine Spalte gelöscht wird, sollen die Daten dieser Spalte (Treffer oder leere Zellen)
keinen Einfluss auf die Löschung der jeweiligen Zeilen haben.
Die Daten einer gelöschten/zu löschenden Spalte werden also bei der Zeilenprüfung nicht beachtet.

Probier das mal:

Sub SelektivLoeschen4()
   Dim arLR, arLC, arQ, rr As Long, cc As Long, ii As Long, rngR As Range, rngC As Range
   Dim oColDel As Object
   Set oColDel = CreateObject("Scripting.Dictionary")             ' neu

   With Sheets("Daten_bereinigen")
      arLR = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row)
      arLC = .Cells(1, 2).Resize(.Cells(.Rows.Count, 2).End(xlUp).Row)
   End With

   With ActiveSheet                    ' Sheets("Daten")
      arQ = .Cells(1, 1).Resize(LZWeTab(Sheets(.Name)), _
            .Cells(1, .Columns.Count).End(xlToLeft).Column)
      For rr = 1 To UBound(arQ)
         For cc = 1 To UBound(arQ, 2)
            If IsArray(arLC) Then
               For ii = 2 To UBound(arLC)
                  If Not IsEmpty(arLC(ii, 1)) Then
                     If arQ(rr, cc) = arLC(ii, 1) Then
                        oColDel(cc) = 0                           ' neu
                        If rngC Is Nothing Then
                           Set rngC = .Columns(cc)
                        Else
                           Set rngC = Union(rngC, .Columns(cc))
                        End If
                     End If
                  End If
               Next ii
            End If
            If Not oColDel.Exists(cc) Then                        ' neu
               If IsArray(arLR) Then
                  For ii = 2 To UBound(arLR)
                     If Not IsEmpty(arLR(ii, 1)) Then
                        If arQ(rr, cc) = arLR(ii, 1) Then
                           If rngR Is Nothing Then
                              Set rngR = .Rows(rr)
                           Else
                              Set rngR = Union(rngR, .Rows(rr))
                           End If
                        End If
                     End If
                  Next ii
               End If
               If IsEmpty(arQ(rr, cc)) Then  ' auch Zeilen, in dene eine leere
                  If rngR Is Nothing Then    '    Zelle steht, werden gelöscht
                     Set rngR = .Rows(rr)
                  Else
                     Set rngR = Union(rngR, .Rows(rr))
                  End If
               End If
            End If                                                ' neu
         Next cc
      Next rr
   End With
   If Not rngR Is Nothing Then rngR.Delete
   If Not rngC Is Nothing Then rngC.Delete
End Sub

Function LZWeTab(wks As Worksheet) As Long
   Dim rng As Range
   With wks
      Set rng = .Cells.Find("*", .Cells(1, 1), xlValues, , xlByRows, xlPrevious)
      If rng Is Nothing Then LZWeTab = 1 Else LZWeTab = rng.Row
   End With
End Function
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich


  

Betrifft: Version 5 von: Erich G.
Geschrieben am: 15.08.2014 06:39:50

Hi Lammi,
so läuft es etwas schneller und runder:

Sub SelektivLoeschen5()
   Dim arLR, arLC, arQ, rr As Long, cc As Long, ii As Long, rngR As Range, rngC As Range
   Dim oColDel As Object, oRowDel As Object
   Set oColDel = CreateObject("Scripting.Dictionary")
   Set oRowDel = CreateObject("Scripting.Dictionary")             ' neu

   With Sheets("Daten_bereinigen")
      arLR = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row)
      arLC = .Cells(1, 2).Resize(.Cells(.Rows.Count, 2).End(xlUp).Row)
   End With

   With ActiveSheet                    ' Sheets("Daten")
      arQ = .Cells(1, 1).Resize(LZWeTab(Sheets(.Name)), _
            .Cells(1, .Columns.Count).End(xlToLeft).Column)
      For rr = 1 To UBound(arQ)
         For cc = 1 To UBound(arQ, 2)
            If oColDel.Exists(cc) Then Stop
            If Not oColDel.Exists(cc) Then
               If IsArray(arLC) Then
                  For ii = 2 To UBound(arLC)
                     If Not IsEmpty(arLC(ii, 1)) Then
                        If arQ(rr, cc) = arLC(ii, 1) Then         ' Treffer Spalte
                           If rngC Is Nothing Then
                              Set rngC = .Columns(cc)
                           Else
                              Set rngC = Union(rngC, .Columns(cc))
                           End If
                           oColDel(cc) = 0
                        End If
                     End If
                  Next ii
               End If
               If Not oRowDel.Exists(rr) Then                     ' neu
                  If IsArray(arLR) Then
                     For ii = 2 To UBound(arLR)
                        If Not IsEmpty(arLR(ii, 1)) Then
                           If arQ(rr, cc) = arLR(ii, 1) Then      ' Treffer Zeile
                              If rngR Is Nothing Then
                                 Set rngR = .Rows(rr)
                              Else
                                 Set rngR = Union(rngR, .Rows(rr))
                              End If
                              oRowDel(rr) = 0                     ' neu
                           End If
                        End If
                     Next ii
                  End If
               End If
               If Not oRowDel.Exists(rr) Then                     ' neu
                  If IsEmpty(arQ(rr, cc)) Then  ' auch Zeilen, in dene eine leere
                     If rngR Is Nothing Then    '    Zelle steht, werden gelöscht
                        Set rngR = .Rows(rr)
                     Else
                        Set rngR = Union(rngR, .Rows(rr))
                     End If
                     oRowDel(rr) = 0                              ' neu
                  End If
               End If
            End If                                                ' neu
         Next cc
      Next rr
   End With
   If Not rngR Is Nothing Then rngR.Delete
   If Not rngC Is Nothing Then rngC.Delete
End Sub
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich und: Schönes Wochenende allerseits!


  

Betrifft: Version 5 - Korrektur von: Erich G.
Geschrieben am: 15.08.2014 07:49:09

Hi Lammi,
in Version 5 steht eine Testanweisung, die noch raus muss, ziemlich weit oben im Code die Zeile

If oColDel.Exists(cc) Then Stop

ist für den realen Betrieb nicht so sinnvoll...

Bei 5000 Quelldatensätzen braucht es ca. 7 Sekunden.

Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich


  

Betrifft: AW: neue Version von: Lammi
Geschrieben am: 15.08.2014 07:20:08

Hallo Erich,

das Marko funktioniert. Ich habe bei den realen Daten eine Zeitprobelm bekommen.
Ich habe nun ca.5000 Datensätze getestet.
Marko2 arbeitet sehr gut setzt ich das Makro 4 ein gibt es klein Ende. Nach mehr mehren Minuten habe ich alles abgebrochen.
Gibt es da noch andere Möglichkeiten?
Bisher habe ich Leerzellen manuell gelöscht. Ich habe mir ein Spalte mit den meisten Leerzellen gefiltert und die gefilterten Daten neu abgesetzt.

Währe das ggf. eine neuer Ansatz?
Nach Ablauf des Makro2 : ...suche die Spalte mit den meisten Leerzellen und lösche alle Datenzeilen mit den Leerzellen.


Gruß
Lammi




 

Beiträge aus den Excel-Beispielen zum Thema "Hallo Erich G.; erweiterte Prüfung"