VBA Duplikate löschen mit Bedingung

Forumthread: 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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

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

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

Beliebteste Forumthreads (12 Monate)

VBA Duplikate löschen mit Bedingung

Forumthread: VBA Duplikate löschen mit Bedingung

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

VBA Duplikate löschen mit Bedingung

Forumthread: VBA Duplikate löschen mit Bedingung

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread