Macro para copiar contenido de una celda a otra que contenga una palabra en espesifico

Tengo en la columna "A" el nombres completos de personas, necesito un macro que me devuelva en la columna "B" todas las personas llamadas "Luis" . Adjunto una imagen de ejemplo.

1

1 Respuesta

210.650 pts. Si de mis mayores gustos, mis disgustos han nacido,...

Prueba con esta macro

Sub buscar_palabra()
Set DATOS = Range("a1").CurrentRegion
PALABRA = UCase(InputBox("TECLEA UN NOMBRE A COPIAR"))
If PALABRA = Empty Then End
With DATOS
    FILAS = .Rows.Count
    For I = 1 To FILAS
        NOMBRE = UCase(.Cells(I, 1))
        On Error Resume Next
        .Cells(I, 2) = WorksheetFunction.Find(PALABRA, NOMBRE, 1)
        On Error GoTo 0
    Next I
    Set DATOS = .CurrentRegion
    .Sort KEY1:=Range(.Columns(2).Address), ORDER1:=xlAscending
    CUENTA = WorksheetFunction.CountIf(.Columns(2), ">0")
    .Columns(2).Clear
    .Resize(CUENTA, 1).Copy: Range("B1").PasteSpecial xlPasteValues
    .CurrentRegion.EntireColumn.AutoFit
End With
End Sub

Tiene el inconveniente de desordenar la columna "A" y es importante conservar el orden de los elementos de la columna "A".

PD: los elementos de la columna "A" esta ordenados por una orden de llegada por decirlo así, así que no conservan un orden alfabético, por lo que si desordenan se malogra el trabajo anterior.

Si no es mucha molestia, deseo poner el nombre a buscar en la línea de comandos, no por inbox

Entonces prueba con esta macro

Sub buscar_datos()
Set datos = Range("a1").CurrentRegion
nombre = "luis"
With datos
    filas = .Rows.Count
    x = 1
    For i = 1 To filas
        cnombre = .Cells(i, 1)
        On Error Resume Next
        nom = WorksheetFunction.Find(UCase(nombre), UCase(cnombre), 1)
        If Err = 0 Then .Cells(x, 2) = .Cells(i, 1): x = x + 1
        On Error GoTo 0
    Next i
End With
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas