Jump to content

Copiar datos repetidos de un rango


juliocesar_seapf

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

 

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

 

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.

 

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

Link to post
Share on other sites

Archived

This topic is now archived and is closed to further replies.

Guest
This topic is now closed to further replies.


  • Posts

    • Efectivamente. Lo único que quiero plantear es que yo, por lo que sea, un día decido quitar una fila en naranja, esa ya no se tiene que generar más veces
    • Ahora si que "mas matao", no lo entiendo.  Vamos a intentar definir en palabras lo que hay que hacer. En una hoja, con un número indeterminado de semanas, hay un número indeterminado de códigos resaltados en naranja. Por cada fila resaltada, deben generarse tantas filas como días falten para llegar al fin de la semana corriente y generarse 7 filas en las semanas siguientes. O sea, si tengo 4 semanas y tengo una fila en naranja que es miércoles, se generan las filas de jueves a domingo de esa semana (Jueves,viernes, sábado y domingo) y de lunes a domingo en las siguientes semanas. Si o no.
    • Excelente Gerson, si funciona muchas gracias
    • Hola @Dani2020  Lo que pasa que estas confundiendo las variables, y eso hace que falle Prueba esto, a ver como te va Sub Modificar() Set H1 = Sheets("CERTIFICACION") Set H2 = Sheets("BD") Set BD = H2.Columns("A").Find(H1.[C4], lookat:=xlWhole) If H1.[C4] <> "" Then If Not BD Is Nothing Then Application.ScreenUpdating = False fi = BD.Row H2.Cells(fi, "B") = H1.[C6] H2.Cells(fi, "C") = H1.[C8] H2.Cells(fi, "D") = H1.[C10] H2.Cells(fi, "E") = H1.[C12] H1.Range("C4,C8,C10,C12").ClearContents Application.ScreenUpdating = True Else VBA.MsgBox "Nombre no encontrado", vbCritical, "AyudaExcel" End If End If Set H1 = Nothing Set H2 = Nothing Set BD = Nothing End Sub Supongo que mi código es similar al @tierra_pampa   Saludos a ambos!
  • Recently Browsing

    No registered users viewing this page.

×
×
  • Create New...

Important Information

Privacy Policy