Macro buscar datos contenidos en una hoja y pegar en hoja nueva

Si es posible su ayuda con lo siguiente:
Tengo una macro creada muy amablemente por unos de sus expertos, pero necesito generar una hoja4 donde me indique los códigos que se encuentran en la hoja2 (matriz).
Esta macro separa los códigos que no estan contenidos en la hoja2, la idea es tambien separar en otra hoja (hoja4) los códigos que si se encuentran en la hoja2:

Agrego la macro inicial:

Sub BuscarDatos()
'Por.Dante Amor
    Application.ScreenUpdating = False
    Application.StatusBar = False
    Set h1 = Sheets("Hoja1")    'Datos a buscar
    Set h2 = Sheets("Hoja2")    'Hoja Matriz
    Set h3 = Sheets("Hoja3")    'Hoja con datos no encontrados
    '
    h1.Columns("A").Interior.ColorIndex = xlNone
    h1.Columns("B").ClearContents
    h3.Cells.Clear
    '
    u1 = h1.Range("A" & Rows.Count).End(xlUp).Row
    u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To u1
        Application.StatusBar = "Procesando registro " & i & " de " & u1
        Set b = h2.Range("A1:A" & u2).Find(h1.Cells(i, "A"), lookat:=xlWhole)
        If Not b Is Nothing Then
            h1.Cells(i, "B") = h2.Cells(b.Row, "B")
        Else
            h1.Cells(i, "A").Interior.ColorIndex = 6
            h1.Cells(i, "B") = "No existe"
            u3 = h3.Range("A" & Rows.Count).End(xlUp).Row + 1
            h3.Cells(u3, "A") = h1.Cells(i, "A")
        End If
    Next
    Application.ScreenUpdating = True
    Application.StatusBar = False
    MsgBox "Terminado", vbInformation
End Sub

1 Respuesta

Respuesta
1

Te anexo la macro

Sub BuscarDatos()
'Por.Dante Amor
    Application.ScreenUpdating = False
    Application.StatusBar = False
    Set h1 = Sheets("Hoja1")    'Datos a buscar
    Set h2 = Sheets("Hoja2")    'Hoja Matriz
    Set h3 = Sheets("Hoja3")    'Hoja con datos no encontrados
    Set h4 = Sheets("Hoja4")    'Hoja con datos encontrados
    '
    h1.Columns("A").Interior.ColorIndex = xlNone
    h1.Columns("B").ClearContents
    h3.Cells.Clear
    h4.Cells.Clear
    '
    u1 = h1.Range("A" & Rows.Count).End(xlUp).Row
    u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To u1
        Application.StatusBar = "Procesando registro " & i & " de " & u1
        Set b = h2.Range("A1:A" & u2).Find(h1.Cells(i, "A"), lookat:=xlWhole)
        If Not b Is Nothing Then
            h1.Cells(i, "B") = h2.Cells(b.Row, "B")
            u4 = h4.Range("A" & Rows.Count).End(xlUp).Row + 1
            h4.Cells(u4, "A") = h1.Cells(i, "A")
        Else
            h1.Cells(i, "A").Interior.ColorIndex = 6
            h1.Cells(i, "B") = "No existe"
            u3 = h3.Range("A" & Rows.Count).End(xlUp).Row + 1
            h3.Cells(u3, "A") = h1.Cells(i, "A")
        End If
    Next
    Application.ScreenUpdating = True
    Application.StatusBar = False
    MsgBox "Terminado", vbInformation
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas