title image


Smiley Re: Selektion des aktuellsten Wertes je Artikelnummer?
Hallo Uli,



kopiere die Liste in eine neue Tabelle, sortiere diese dann nach Bestelldatum

absteigend, markiere eine Zelle der Spalte Artikelnummer und lass dann dieses Makro laufen:



Sub DoppelteEintraegeLoeschen()        'Uwe Küstner, 20060514        Dim colUnique As New Collection    Dim lngAbZeile As Long    Dim lngArr As Long    Dim lngC As Long    Dim lngCalc As Long    Dim lngDup As Long    Dim lngMaxArrays As Long    Dim lngZ As Long    Dim lngZeile As Long    Dim lngZeilenArray As Long    Dim lngZeilenBereich As Long    Dim rngArea As Range    Dim rngAuswahl As Range    Dim rngC As Range    Dim rngDel() As Range    Dim rngSel As Range    Dim strSuchbereich As String    Dim strZeile As String    Dim varAuswahl() As Variant    Dim varC As Variant    Set rngSel = Selection.EntireColumn    lngZeilenBereich = ActiveSheet.UsedRange.Rows.Count    On Error GoTo FehlerBehandlung    lngCalc = Application.Calculation    Set rngAuswahl = Application.Intersect(Selection.EntireColumn, ActiveSheet.UsedRange)    strSuchbereich = rngAuswahl.Address(0, 0)    lngAbZeile = Abs(Clng(Application.InputBox( _        vbLf & "Ab welcher Zeile soll geprüft werden?", "Prüfbereich festlegen", 2, , , , , 1)))    If lngAbZeile > 0 And lngAbZeile <= lngZeilenBereich Then        Set rngAuswahl = Application.Intersect(Rows(lngAbZeile & ":" & lngZeilenBereich), rngSel)    Else        MsgBox "Die Zeile " & lngAbZeile & " liegt außerhalb des Bereichs """ & strSuchbereich & """!"        Exit Sub    End If    lngZeilenArray = lngZeilenBereich - lngAbZeile + 1    rngAuswahl.Select    lngArr = 1    Redim rngDel(lngArr)    lngMaxArrays = lngZeilenBereich / 50    strSuchbereich = rngAuswahl.Address(0, 0)    Application.Calculation = xlCalculationManual    Application.ScreenUpdating = False    For Each rngArea In rngAuswahl.Areas        For Each rngC In rngArea.Columns            lngC = lngC + 1            Redim Preserve varAuswahl(1 To lngC)            varAuswahl(lngC) = rngC.Value        Next rngC    Next rngArea    colUnique.Add 0, "" 'wenn auch die 1. Leerzeile berücksichtigt werden soll    For lngZeile = 1 To lngZeilenArray        strZeile = ""        For lngZ = 1 To lngC            strZeile = strZeile & CStr(varAuswahl(lngZ)(lngZeile, 1))        Next lngZ        colUnique.Add lngZeile, strZeile    Next lngZeile    Set rngDel(0) = rngDel(1)    lngArr = lngArr + (rngDel(lngArr) Is Nothing)    If lngArr > 1 Then        For lngZ = 2 To lngArr            Set rngDel(0) = Application.Union(rngDel(0), rngDel(lngZ))        Next lngZ    End If    lngDup = rngDel(0).Cells.Count / 256    Application.Intersect(rngSel, rngDel(0)).Select    Application.ScreenUpdating = True    If MsgBox("Es wurden " & lngDup & " Duplikate im Bereich" & vbLf & _        strSuchbereich & vbLf & _        "gefunden." & vbLf & vbLf & "Sollen sie jetzt gelöscht werden?", _        vbQuestion Or vbYesNo Or vbDefaultButton2) = vbYes Then        Application.ScreenUpdating = False        For lngZ = lngArr To 1 Step -1            rngDel(lngZ).Delete        Next lngZ        rngSel.Select        Application.ScreenUpdating = True    End If    FehlerBehandlung:    Select Case Err.Number        Case 457            If rngDel(lngArr) Is Nothing Then                Set rngDel(lngArr) = Rows(lngZeile + lngAbZeile - 1)            Else                Set rngDel(lngArr) = Application.Union(rngDel(lngArr), Rows(lngZeile + lngAbZeile - 1))            End If            If rngDel(lngArr).Areas.Count = lngMaxArrays Then                lngArr = lngArr + 1                Redim Preserve rngDel(lngArr)            End If            Resume Next        Case 13, 91            MsgBox "Im Bereich" & vbLf & vbLf & """" & strSuchbereich & """" & vbLf & vbLf & "gibt es keine Duplikate."        Case Is > 0            MsgBox "Fehlernummer: " & Err.Number & vbLf & vbLf & _                "Felerbeschreibung: " & Err.Description            'für Entwicklung zum Testen            ' Application.Calculation = lngCalc            ' On Error GoTo 0            ' Resume    End Select    Application.Calculation = lngCalcEnd Sub



Eine Erklärung zum Makro findest Du hier: Duplikate löschen spezial

Gruß Uwe



geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: