Eliminar duplicados por referencias

riopar10 · el 14 de diciembre

Hola a todos, no tengo ni la menor idea de como hacer esto, he probado varias macros del foro, pero no son del resultado deseado.

Normalmente la estructura del archivo será siempre igual, siguendo esta estructura, la columna A tendrá siempr e las referencias de los productos de la tienda, lo que me gustaría es que con esa referencia de A poder eliminar todas las filas incluso de la columna A que tengan la referencia mia ( columna D ), dejando solamente los productos cuya referencia no coincidan entre A y D.

Si es posible y no es mucho pedir, continuando con el mismo ejemplo y tambien necesario para mi, la columna H que es de descripción corta del producto tenga un máximo de 350 caracteres, borrando el resto, pero que no corte las palabras ( mama - mam), que lo deje en la palabra anterior completa y que ponga ... (puntos suspensivos).

Espero haberme explicado bien y que me entendais, solo agradeceros vuestra ayuda, por que estoy perdido en excel.

Tengo el 2010

Gracias.

ejemplo.zip

Antoni · el 15 de diciembre

Hola:

Te devuelvo el archivo con 2 macros que hacen lo que pides.

Saludos

Copia de ejemplo.xls

JM123 · el 15 de diciembre

Hola

Mientras estaba elaborando mi respuesta ya te habia respondido el gran MacroAntonio pero ya que la he hecho y no es igual que la MacroAntonio (es parecida) te la mando. Solamente la parte de eliminar duplicados.

Para limitar nº de caracteres en una celda pudes utilizar validacion de datos.

Saludos

ejemplo.rar

Antoni · el 15 de diciembre

Hola JM123:

Lamento comunicarte que tu macro tiene una pequeña pega, si hay 2 filas seguidas a eliminar, solo elimina la primera.

El problema viene porqué al eliminar una fila, todas las restantes suben una fila, con lo que al avanzar otra fila con el .Offset, te saltas una. Una forma de hacerlo sería así.




Private Sub CommandButton1_Click()


Range("A1").Select

Do Until ActiveCell = ""

   If ActiveCell = ActiveCell.Offset(0, 3) Then

      ActiveCell.EntireRow.Delete

   Else

      ActiveCell.Offset(1, 0).Select

   End If

Loop

Range("A1").Select


End Sub




[/CODE]

Otra forma consiste en recorrer el rango del final al principio.

Y otra forma es la que utilizo yo, borrar todas las líneas de una sola vez.

Saludos

riopar10 · el 15 de diciembre

puedes poner la que utilizas tu + la eliminacion de caracteres y si por cualquier motivo tengo que cambiar de columna como lo haria para que funcionase bien

Gracias a todos

Antoni · el 16 de diciembre

Hola, las macros están en el archivo que subí, pero si quieres verlas:

[COLOR=#0000cd][B]Sub EliminarIguales[/B][/COLOR]()


    Dim Rango As Range, Fila As Long, ÚltimaFila As Long


    Application.ScreenUpdating = False


    ÚltimaFila = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1

    For Fila = ActiveSheet.UsedRange.Row To ÚltimaFila

       Application.StatusBar = "Procesando fila " & Fila & " / " & ÚltimaFila

       If Range([COLOR=#ff0000][B]"A"[/B][/COLOR] & Fila).Value = Range([B][COLOR=#ff0000]"D"[/COLOR][/B] & Fila).Value Then [COLOR=#ff0000][B]'Columnas de comparación[/B][/COLOR]

           If Rango Is Nothing = True Then

              Set Rango = Rows(Fila)

           Else

              Set Rango = Application.Union(Rango, Rows(Fila))

           End If

       End If

    Next Fila


    If Rango Is Nothing = False Then

       Rango.Select

       Selection.Delete

       ActiveCell.Select

    End If


    Application.StatusBar = "Listo"

    Application.ScreenUpdating = True


End Sub

[/CODE]

[CODE][B][COLOR=#0000cd]Sub LimitarDescripción[/COLOR][/B]()
Dim Rango As Range, Fila As Long, ÚltimaFila As Long

Application.ScreenUpdating = False

ÚltimaFila = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
For Fila = ActiveSheet.UsedRange.Row To ÚltimaFila
Application.StatusBar = "Procesando fila " & Fila & " / " & ÚltimaFila
If Len(Range([B][COLOR=#ff0000]"H"[/COLOR][/B] & Fila).Value) > [B][COLOR=#ff0000]347[/COLOR][/B] Then [B][COLOR=#ff0000]'Columna y longitud máxima[/COLOR][/B]
Range([COLOR=#ff0000][B]"H"[/B][/COLOR] & Fila).Value = Mid(Range([B][COLOR=#ff0000]"H"[/COLOR][/B] & Fila).Value, 1, 347)
x = InStrRev(Range([COLOR=#ff0000][B]"H"[/B][/COLOR] & Fila).Value, " ")
If x > 0 Then Range([COLOR=#ff0000][B]"H"[/B][/COLOR] & Fila).Value = Mid(Range([COLOR=#ff0000][B]"H"[/B][/COLOR] & Fila).Value, 1, x - 1) & "[COLOR=#ff0000][B]...[/B][/COLOR]"
End If
Next Fila

Application.StatusBar = "Listo"
Application.ScreenUpdating = True

End Sub
[/CODE]

riopar10 · el 16 de diciembre

Gracias, no consigo hacerle funcionar, os envio el archivo real, he quitado algunas columnas que no son necesarias para la prueba, podeis corregirlo en el archivo y luego yo la subiria bien.