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
Respuesta de James Bond
2
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
1 respuesta más de otro experto
Respuesta de Dante Amor
2
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.