Con el numero de documento traer a otra hoja dirección teléfono etc

Esta macro me carga si coloco uno por uno pero si pego varios en la columna no, alguien me ayuda a corregir por favor

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column <> 1 Then Exit Sub
Dim mihoja As String, Donde As String
Dim Quebusco As String
Dim resulta As Object
Dim ubicado As String
'la variable mihoja guarda la hoja donde se hará la búsqueda
mihoja = "Octubre"
'la variable Donde guarda el rango donde debe efectuarse la búsqueda
Donde = "B2:B10000"
'la variable Quebusco guarda el dato a buscar que se encuentra en la celda B2
Quebusco = Target.Value
'se crea un objeto con el resultado de la función Find
Set resulta = Sheets(mihoja).Range(Donde).Find(Quebusco, LookIn:=xlValues, LookAt:=xlWhole)
If resulta Is Nothing Then
'si no se encuentra el dato puede mostrar un mensaje de error como el siguiente
'MsgBox "No se encontró el dato", vbCritical, "NO ENCONTRADO"
Else
'si encontró el dato devolverá a continuación el resto de datos
Target.Offset(0, 1).Value = resulta.Offset(0, 1)
Target.Offset(0, 2).Value = resulta.Offset(0, 2)
Target.Offset(0, 3).Value = resulta.Offset(0, 3)
Target.Offset(0, 4).Value = resulta.Offset(0, 6)
Target.Offset(0, 5).Value = resulta.Offset(0, 8)
Target.Offset(0, 6).Value = resulta.Offset(0, 9)
Target.Offset(0, 7).Value = resulta.Offset(0, 10)
'continuar con el resto de campos
End If
'se limpia la variable
Set resulta = Nothing

End Sub

1

1 Respuesta

4.383.400 pts. Sancho, si los perros ladran ...

H o l a:

Te anexo la macro actualizada

Private Sub Worksheet_Change(ByVal Target As Range)
'Act.Por.Dante Amor
    If Target.Count > 1000 Then Exit Sub
    If Target.Column <> 1 Then Exit Sub
    '
    Set h = Sheets("Octubre")       'la variable h guarda la hoja de la búsqueda
    Set r = h.Range("B2:B10000")    'la variable r guarda el rango de la búsqueda
    '
    For Each c In Target            'Para cada celda copiada
                                    'El objeto b guarda el resultado de la búsqueda
        Set b = r.Find(c, LookIn:=xlValues, LookAt:=xlWhole)
        If Not b Is Nothing Then    'si encontró el dato devolverá el resto de datos
            c.Offset(0, 1) = b.Offset(0, 1)
            c.Offset(0, 2) = b.Offset(0, 2)
            c.Offset(0, 3) = b.Offset(0, 3)
            c.Offset(0, 4) = b.Offset(0, 6)
            c.Offset(0, 5) = b.Offset(0, 8)
            c.Offset(0, 6) = b.Offset(0, 9)
            c.Offset(0, 7) = b.Offset(0, 10)
        End If
    Next
End Sub

La macro soporta hasta una copia de 1000 (mil) celdas, no te recomiendo un mayor número porque se puede bloquear excel.

Prueba y me comentas.


':)
':)

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas