Macro para cargar los datos correspondientes a un documento en excel
Tengo una base de datos y otra donde cargo una columna con documentos para traer los registros asociados
1 Respuesta
H o l a:
Si no quieres utilizar el offset, te anexo la siguiente alternativa para utilizar Cells:
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
Cells(c.Row, "B") = h.Cells(b.Row, "C")
Cells(c.Row, "C") = h.Cells(b.Row, "D")
Cells(c.Row, "D") = h.Cells(b.Row, "E")
Cells(c.Row, "E") = h.Cells(b.Row, "H")
Cells(c.Row, "F") = h.Cells(b.Row, "J")
Cells(c.Row, "G") = h.Cells(b.Row, "K")
Cells(c.Row, "H") = h.Cells(b.Row, "L")
End If
Next
End Sub':) S a l u d o s . D a n t e A m o r ':) Si es lo que necesitas. Recuerda valorar la respuesta. G r a c i a s.
Mil gracias justo lo que necesitaba
Estoy teniendo problemas: cuando encuentra dos documentos me carga la información del segundo igual a la del primero me puedes ayudar por favor.
pdt pueden repetirse los documentos pero el resto de los datos son diferentes
H o l a:
La clave para la búsqueda es el documento, si existen 2 o más documentos iguales, entonces necesitamos de una segunda clave para identificar cuál registro pertenece a cuál documento.
¿Dime si tienes una segunda clave?
Si podría ser la subpartida, De la hoja Mes seria la columna H, y de la hoja XML se la columna Y,
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("Mes") '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
Set h2 = Sheets("xml") 'la variable h guarda la hoja de la búsqueda
Set r2 = h2.Range("M2:M10000") '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
Cells(c.Row, "B") = h.Cells(b.Row, "C")
Cells(c.Row, "C") = h.Cells(b.Row, "D")
Cells(c.Row, "D") = h.Cells(b.Row, "E")
Cells(c.Row, "E") = h.Cells(b.Row, "H")
Cells(c.Row, "F") = h.Cells(b.Row, "J")
Cells(c.Row, "G") = h.Cells(b.Row, "K")
Cells(c.Row, "H") = h.Cells(b.Row, "L")
End If
For Each c2 In Target 'Para cada celda copiada
'El objeto b guarda el resultado de la búsqueda
Set b2 = r2.Find(c2, LookIn:=xlValues, LookAt:=xlWhole)
If Not b2 Is Nothing Then 'si encontró el dato devolverá el resto de datos
Cells(c2.Row, "I") = h2.Cells(b2.Row, "N")
Cells(c2.Row, "J") = h2.Cells(b2.Row, "O")
Cells(c2.Row, "K") = h2.Cells(b2.Row, "P")
Cells(c2.Row, "L") = h2.Cells(b2.Row, "Y")
Cells(c2.Row, "M") = h2.Cells(b2.Row, "Z")
Cells(c2.Row, "N") = h2.Cells(b2.Row, "AA")
Cells(c2.Row, "O") = h2.Cells(b2.Row, "AB")
Cells(c2.Row, "P") = h2.Cells(b2.Row, "AC")
Cells(c2.Row, "Q") = h2.Cells(b2.Row, "AD")
Cells(c2.Row, "R") = h2.Cells(b2.Row, "AF")
Cells(c2.Row, "S") = h2.Cells(b2.Row, "AG")
Cells(c2.Row, "T") = h2.Cells(b2.Row, "AH")
Cells(c2.Row, "U") = h2.Cells(b2.Row, "AI")
End If
Next
Next
End Sub
¡Gracias!
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("Mes") '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
Set h2 = Sheets("xml") 'la variable h guarda la hoja de la búsqueda
Set r2 = h2.Range("M2:M10000") '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
Cells(c.Row, "B") = h.Cells(b.Row, "C")
Cells(c.Row, "C") = h.Cells(b.Row, "D")
Cells(c.Row, "D") = h.Cells(b.Row, "E")
Cells(c.Row, "E") = h.Cells(b.Row, "H")
Cells(c.Row, "F") = h.Cells(b.Row, "J")
Cells(c.Row, "G") = h.Cells(b.Row, "K")
Cells(c.Row, "H") = h.Cells(b.Row, "L")
End If
For Each c2 In Target 'Para cada celda copiada
'El objeto b guarda el resultado de la búsqueda
Set b2 = r2.Find(c2, LookIn:=xlValues, LookAt:=xlWhole)
If Not b2 Is Nothing Then 'si encontró el dato devolverá el resto de datos
Cells(c2.Row, "I") = h2.Cells(b2.Row, "N")
Cells(c2.Row, "J") = h2.Cells(b2.Row, "O")
Cells(c2.Row, "K") = h2.Cells(b2.Row, "P")
Cells(c2.Row, "L") = h2.Cells(b2.Row, "Y")
Cells(c2.Row, "M") = h2.Cells(b2.Row, "Z")
Cells(c2.Row, "N") = h2.Cells(b2.Row, "AA")
Cells(c2.Row, "O") = h2.Cells(b2.Row, "AB")
Cells(c2.Row, "P") = h2.Cells(b2.Row, "AC")
Cells(c2.Row, "Q") = h2.Cells(b2.Row, "AD")
Cells(c2.Row, "R") = h2.Cells(b2.Row, "AF")
Cells(c2.Row, "S") = h2.Cells(b2.Row, "AG")
Cells(c2.Row, "T") = h2.Cells(b2.Row, "AH")
Cells(c2.Row, "U") = h2.Cells(b2.Row, "AI")
End If
Next
Next
End Sub
¡Gracias!
H o l a:
Tengo que agregar un ciclo a la macro, podrías crear una pregunta nueva, en el tema de microsoft excel, en el desarrollo de la pregunta escribe: "para Dante Amor", ahí me describes con detalle lo que necesitas.
Sal u dos
