Eliminar Datos repetidos y el Max y Min

Como puedo eliminar datos repetidos pero con el ordenamiento de menor a mayor estos debo eliminar el Max y el Min dependiendo de los duplicados o repetidos ejemplo

En este lo tengo ya ordenado por nombre pero quiero buscar por ejemplo de pedro el mínimo de horas y borrarlo y el max y borrarlo así sucesivamente con todos los empleados

2

2 Respuestas

4.709.275 pts. Sancho, si los perros ladran ...

Para el caso de hugo que solamente tiene 2 registros, ¿los dos registros se deben eliminar?

Y para el caso de juan que solamente tiene 1 registro, ¿también qué se borre el registro?

Claro, me falto especificar esa parte, en caso que sean datos menos a 4 se deben dejar y así considerar lo anterior mencionado

Saludos!

Ejecuta la macro sobre la hoja con tus datos.

Deben estar ordenados por nombre y horas de menor a mayor (tal y como está en tu imagen)

Sub Borrar_Max_Min()
'Por Dante Amor
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set h1 = ActiveSheet
    Set h2 = Sheets.Add
    u1 = h1.Range("A" & Rows.Count).End(xlUp).Row
    h1.Columns("A").Copy h2.Columns("A")
    h2.Range("A1:A" & u1).RemoveDuplicates Columns:=1, Header:=xlYes
    u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To u2
        nombre = h2.Cells(i, "A").Value
        cuenta = WorksheetFunction.CountIf(h1.Range("A2:A" & u1), nombre)
        If cuenta > 3 Then
            Set b = h1.Columns("A").Find(nombre, lookat:=xlWhole, SearchDirection:=xlPrevious)
            If Not b Is Nothing Then
                h1.Rows(b.Row).Delete
            End If
            Set b = h1.Columns("A").Find(nombre, lookat:=xlWhole)
            If Not b Is Nothing Then
                h1.Rows(b.Row).Delete
            End If
        End If
    Next
    h2.Delete
    Application.ScreenUpdating = True
    MsgBox "Fin"
End Sub
'

[Si te ayudó la información, no olvides valorar la respuesta.
210.675 pts. Si de mis mayores gustos, mis disgustos han nacido,...

Prueba esta macro de cada nombre elimina el dato con la menor y la mayor cantidad

Sub eliminar_repetidos()
Dim funcion As WorksheetFunction
Set datos = Range("a1").CurrentRegion
Set funcion = WorksheetFunction
With datos
    .Sort _
        key1:=Range(.Columns(1).Address), order1:=xlAscending, _
        key2:=Range(.Columns(2).Address), order2:=xlAscending, _
        Header:=xlYes
        f = .Rows.Count: c = .Columns.Count
        Set tabla = .Columns(c + 4).Resize(f, c)
        .Copy
        With tabla
            .PasteSpecial
            .RemoveDuplicates Columns:=1
                For i = 2 To .CurrentRegion.Rows.Count
                    nombre = .Cells(i, 1)
                    cuenta = funcion.CountIf(datos.Columns(1), nombre)
                    fila = funcion.Match(nombre, datos.Columns(1), 0)
                    If cuenta > 4 Then
                        Set empleado = datos.Rows(fila).Resize(cuenta)
                        mini = funcion.Min(empleado.Columns(2))
                        maxi = funcion.Max(empleado.Columns(2))
                        fila1 = funcion.Match(mini, empleado.Columns(2), 0)
                        fila2 = funcion.Match(maxi, empleado.Columns(2), 0)
                        empleado.Rows(fila1).Clear
                        empleado.Rows(fila2).Clear
                    End If
                Next i
                .Clear
        End With
.Sort _
        key1:=Range(.Columns(1).Address), order1:=xlAscending, _
        key2:=Range(.Columns(2).Address), order2:=xlAscending, _
        Header:=xlYes
End With
Set tabla = Nothing: Set empleado = Nothing: Set datos = Nothing
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas