Jump to content
juliocesar_seapf

Copiar datos repetidos de un rango

Recommended Posts

amigos, como esta

trato de hacer lo contrario a este codigo

Sub ValoresUnicos()
Dim listaOrigen As Range

On Error Resume Next
Set listaOrigen = Application.InputBox _
(Prompt:="Seleccione la columna donde estan los # Ots:", Title:="Seleccionar 1 Columna", Type:=8)

listaOrigen.AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=ActiveCell, Unique:=True

Canceled:
End Sub

cambien este valor, pero me copia todo el rango idéntico

Action:=xlFilterCopy, CopyToRange:=ActiveCell, Unique:=False

sera que me ayudan

 

gracias

 

Share this post


Link to post
Share on other sites

Prueba con estas macros, a ver si alguna de ellas es lo que estas buscando:

Sub ValoresNoRepetidos()
Dim listaOrigen As Range, x As Long
Set listaOrigen = Application.InputBox _
                     (Prompt:="Seleccione la columna donde estan los # Ots:", _
                      Title:="Seleccionar 1 Columna", Type:=8)
columna = Split(listaOrigen.Address, ":")(1)
Application.ScreenUpdating = False
For x = 2 To Range(columna & Rows.Count).End(xlUp).Row
   contador = WorksheetFunction.CountIf(listaOrigen, Range(columna & x).Value)
   If contador = 1 Then
      ActiveCell = Range(columna & x).Value
      ActiveCell.Offset(1, 0).Activate
   End If
Next
End Sub

Sub ValoresRepetidos()
Dim listaOrigen As Range, x As Long
Set listaOrigen = Application.InputBox _
                     (Prompt:="Seleccione la columna donde estan los # Ots:", _
                      Title:="Seleccionar 1 Columna", Type:=8)
columna = Split(listaOrigen.Address, ":")(1)
Application.ScreenUpdating = False
For x = 2 To Range(columna & Rows.Count).End(xlUp).Row
   contador = WorksheetFunction.CountIf(listaOrigen, Range(columna & x).Value)
   If contador > 1 Then
      ActiveCell = Range(columna & x).Value
      ActiveCell.Offset(1, 0).Activate
   End If
Next
End Sub

 

Share this post


Link to post
Share on other sites

hola a todos, y gracias por sus respuesta...

Gerson, siempre me das otra perpestiva que me ayuda a solucionar mi problema y futuros problemas.

esta vez el codigo de mi amigo Super Macro antonico me quedo muy bien. gracias Macro.

 

Sub ValoresRepetidos()
Dim listaOrigen As Range, x As Long
Set listaOrigen = Application.InputBox _
                     (Prompt:="Seleccione la columna donde estan los # Ots:", _
                      Title:="Seleccionar 1 Columna", Type:=8)
columna = Split(listaOrigen.Address, ":")(1)
Application.ScreenUpdating = False
For x = 2 To Range(columna & Rows.Count).End(xlUp).Row
   contador = WorksheetFunction.CountIf(listaOrigen, Range(columna & x).Value)
   If contador > 1 Then
      ActiveCell = Range(columna & x).Value
      ActiveCell.Offset(1, 0).Activate
   End If
Next
End Sub

 

saludos

tema solucionado.

 

Share this post


Link to post
Share on other sites

Haciendo pruebas, en los resultados de la macro de Macro Antonio se repiten los códigos, yo había interpretado que necesitabas "extraer" solo los que se repiten mas de una vez (los que aparecían una vez no), eso es para mi, lo contrario de extraer "únicos" 

Te adjunto de nuevo según lo que te explique, incluyendo un contador por cada código, de paso quedara como un aporte mas :rolleyes:

Sub ObtenerRepetidos_GP()

'************ By Gerson Pineda ************

On Error GoTo err:
Dim listaOrigen As Range
Set listaOrigen = Application.InputBox _
(Prompt:="Seleccione la columna donde estan los codigos:", _
Title:="Seleccionar solo una columna", Type:=8)

Application.ScreenUpdating = False
With listaOrigen.SpecialCells(xlCellTypeConstants)
    vca = Cells(1, .Column).Address(0, 0)
    .Offset(, 1).Formula = "=IF(COUNTIF(" & .Address & ", " & _
    vca & ")>=2,""Repetido"",""No Repetido"")"
    .Offset(, 2).Formula = "=COUNTIF(" & .Address & ", " & _
    vca & ")"
    Cells(1, .Column + 2) = "Contador"
    With .CurrentRegion
        .AutoFilter 2, "No Repetido"
        .Offset(1).EntireRow.SpecialCells(xlCellTypeVisible).Delete
        .AdvancedFilter 2, , Cells(1, .Column + 4), 1
    End With
    'PARA ELIMINAR LAS 6 COLUMNAS ADYACENTES DE LA DERECHA
    .Offset(, 5).Delete
    .Resize(, 4).Delete
End With

err:
Set listaOrigen = Nothing
Application.ScreenUpdating = True

End Sub

 

Saludos a ambos!

Obtener repetidos_GP.rar

Share this post


Link to post
Share on other sites
Guest
This topic is now closed to further replies.



×
×
  • Create New...

Important Information

Privacy Policy


CTA Templates.png