Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA Duplikate löschen mit Bedingung

VBA Duplikate löschen mit Bedingung
08.04.2009 10:40:08
Carmen
Hallo ihr lieben Spezi´s,
eigentlich würde ich es gerne allein können doch nach reiflicher überlegung komme ich nicht zu gewünschtem ergebnis.
Hab eine Tabelle in der in Spalte A Tarifbezeichnungen sind die doppelt sind.
In Spalte B steht seit wann die Tarife gültig sind.
Nun ist es so das dort z.B steht
Tarif1 gültig seit 01.01.08
Tarif1 gültigseit 01.01.09
Nun sollen die Duplikattarife gelöscht werden, die vor dem jüngsten gültigkeitsdatum sind, sprich hier der von 01.01.08.
Wie bekomme ich das hin.
Vielen Dank vorab
Grüße Carmen

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

Betreff
Datum
Anwender
Anzeige
AW: VBA Duplikate löschen mit Bedingung
08.04.2009 10:45:13
Tino
Hallo,
steht in der Spalte B wirklich "gültig seit 01.01.08" oder ist dort nur das Datum drin?
Soll die komplette Zeile gelöscht werden oder nur der Inhalt der Zellen?
Gruß Tino
AW: VBA Duplikate löschen mit Bedingung
08.04.2009 10:58:49
Carmen
Hallo Tino,
da steht nur das datum drin und es soll die komplette Zeile gelöscht werden.
Kannst Du das?
Grüße Carmen
AW: VBA Duplikate löschen mit Bedingung
08.04.2009 11:24:36
Tino
Hallo,
ob ich es kann weis ich noch nicht, aber Du kannst es mal hiermit versuchen.
Es werden 3 Hilfsspalten am Ende der Tabelle verwendet, diese werden am Ende wieder gelöscht.
Nicht ausgiebig getestet.
Sub TestLoescheZeilen()
Dim LRow
Dim Bereich As Range
Dim myTab As Worksheet

Set myTab = Worksheets("Tabelle1") 'Name anpassen 

With Application
 .ScreenUpdating = False

    LRow = myTab.Range("A:B").Find("*", , xlValues, 2, 1, 2, False, False, False).Row
    Set Bereich = myTab.Range("A1:A" & LRow)
    Set Bereich = Bereich.Offset(0, Columns.Count - 2)
    
    Bereich.Offset(0, -1).FormulaR1C1 = "=Row()"
    Bereich.Offset(0, -1).Value = Bereich.Offset(0, -1).Value
    Bereich.FormulaR1C1 = "=IF(COUNTIF(R2C1:R" & LRow & "C1,RC1)>1,RC1&RC2,"""")"
    myTab.UsedRange.Sort Bereich(1), xlAscending, , , , , , xlNo
    Bereich.Offset(0, 1).FormulaR1C1 = "=IF(AND(RC1=R[1]C1,RC[-1]<=R[1]C[-1]),0,"""")"
    
    If .WorksheetFunction.CountIf(Bereich.Offset(0, 1), 0) > 0 Then
     Bereich.Offset(0, 1).SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
    End If
    
    myTab.UsedRange.Sort Bereich.Offset(0, -1)(1), xlAscending, , , , , , xlNo
    
    myTab.Columns(myTab.Columns.Count).Delete
    myTab.Columns(myTab.Columns.Count - 1).Delete
    myTab.Columns(myTab.Columns.Count - 2).Delete
    
 .ScreenUpdating = True
End With

End Sub


Gruß Tino

Anzeige
AW: VBA Duplikate löschen mit Bedingung
08.04.2009 12:48:36
Carmen
Lieber Tino,
es dauert, aber funktioniert wunderbar vielen Dank!!!!
Grüße Carmen
schneller, so gehts.
08.04.2009 13:56:08
Tino
Hallo,
habe mal etwas gebastelt, so müsste der Code schneller sein,
zumindest wird es kaum schneller gehen.
Sub TestLoescheZeilen()
Dim LRow
Dim Bereich As Range, Bereich1 As Range
Dim myTab As Worksheet
Dim iCalc As Integer

Set myTab = Worksheets("Tabelle1") 'Name anpassen 

With Application
 .ScreenUpdating = False
  iCalc = .Calculation
 .Calculation = xlCalculationManual
    
    LRow = myTab.Range("A:B").Find("*", , xlValues, 2, 1, 2, False, False, False).Row
    
    
    Set Bereich1 = myTab.Range("A1:A" & LRow).Offset(0, Columns.Count - 2)
    Bereich1.FormulaR1C1 = "=ROW()"

    Set Bereich = myTab.Range("A1:B" & LRow)
    myTab.UsedRange.Sort Bereich(1, 1), xlAscending, Bereich(1, 2), , xlAscending, , , xlYes
    
    
    Set Bereich = myTab.Range("A1:A" & LRow).Offset(0, Columns.Count - 1)
    Bereich.FormulaR1C1 = "=IF(AND(RC1=R[1]C1,RC2<=R[1]C2),True,ROW())"
    myTab.UsedRange.Sort Bereich1(1), xlAscending, , , , , , xlYes
    
    If .WorksheetFunction.CountIf(Bereich, True) > 0 Then
     Bereich.SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
    End If
    
    myTab.UsedRange.Sort Bereich.Offset(0, -1)(1), xlAscending, , , , , , xlYes
    
    myTab.Columns(myTab.Columns.Count).Delete
    myTab.Columns(myTab.Columns.Count - 1).Delete
    
 .Calculation = iCalc
 .ScreenUpdating = True
End With

End Sub


Gruß Tino

Anzeige
noch ein Fehler gefunden.
08.04.2009 14:14:02
Tino
Hallo,
so gehts aber jetzt.
Sub TestLoescheZeilen()
Dim LRow
Dim Bereich As Range, Bereich1 As Range
Dim myTab As Worksheet
Dim iCalc As Integer

Set myTab = Worksheets("Tabelle1") 'Name anpassen 

With Application
 .ScreenUpdating = False
  iCalc = .Calculation
 .Calculation = xlCalculationManual
    
    LRow = myTab.Range("A:B").Find("*", , xlValues, 2, 1, 2, False, False, False).Row
    
    
    Set Bereich1 = myTab.Range("A1:A" & LRow).Offset(0, Columns.Count - 2)
    Bereich1.FormulaR1C1 = "=ROW()"

    Set Bereich = myTab.Range("A1:B" & LRow)
    myTab.UsedRange.Sort Bereich(1, 1), xlAscending, Bereich(1, 2), , xlAscending, , , xlYes
    
    
    Set Bereich = Bereich1.Offset(0, 1)
    Bereich.FormulaR1C1 = "=IF(AND(RC1=R[1]C1,RC2<=R[1]C2),True,ROW())"
    myTab.UsedRange.Sort Bereich(1), xlAscending, , , , , , xlYes
    
    If .WorksheetFunction.CountIf(Bereich, True) > 0 Then
     Bereich.SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
    End If
    
    myTab.UsedRange.Sort Bereich1(1), xlAscending, , , , , , xlYes
    
    myTab.Columns(myTab.Columns.Count).Delete
    myTab.Columns(myTab.Columns.Count - 1).Delete
    
 .Calculation = iCalc
 .ScreenUpdating = True
End With

End Sub


Gruß Tino

Anzeige
AW: noch ein Fehler gefunden.
08.04.2009 18:12:16
Carmen
Tino das ist super vielen Dank!
noch eine verbesserte Version
08.04.2009 12:14:09
Tino
Hallo,
hier noch eine, kommt mit nur zwei Hilfsspalten aus.
Ich gehe davon aus, dass in der Zeile 1 eine Überschrift enthalten ist.
Sub TestLoescheZeilen()
Dim LRow
Dim Bereich As Range
Dim myTab As Worksheet

Set myTab = Worksheets("Tabelle1") 'Name anpassen 

With Application
 .ScreenUpdating = False

    LRow = myTab.Range("A:B").Find("*", , xlValues, 2, 1, 2, False, False, False).Row
    
    Set Bereich = myTab.Range("A1:A" & LRow).Offset(0, Columns.Count - 2)
    Bereich.FormulaR1C1 = "=Row()"
    Bereich.Value = Bereich.Value
    
    Set Bereich = myTab.Range("A1:B" & LRow)
    myTab.UsedRange.Sort Bereich(1, 1), xlAscending, Bereich(1, 2), , xlAscending, , , xlYes
    
    Set Bereich = myTab.Range("A1:A" & LRow)
    Set Bereich = Bereich.Offset(0, Columns.Count - 1)
    Bereich.FormulaR1C1 = "=IF(AND(RC1=R[1]C1,RC2<=R[1]C2),0,"""")"
    
    
    If .WorksheetFunction.CountIf(Bereich, 0) > 0 Then
     Bereich.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
    End If
    
    myTab.UsedRange.Sort Bereich.Offset(0, -1)(1), xlAscending, , , , , , xlYes
    
    myTab.Columns(myTab.Columns.Count).Delete
    myTab.Columns(myTab.Columns.Count - 1).Delete
    
 .ScreenUpdating = True
End With

End Sub


Gruß Tino

Anzeige

304 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige