¿Cómo insertar datos de una hoja a otra con base al ID de consulta?
Solicito su amable ayuda para insertar datos de una hoja a otra.
En la hoja "FORMATO" se realiza la consulta de la hoja "BD" por medio del RFC el cual funciona como el ID. En dicha hoja y a partir de la fila B20 y hasta la celda P20 ( señalados en color rojo) están ubicados los datos nuevos que se deben registrar en la hoja "CONTABILIDAD" a partir del la columna "K" según el RFC de la consulta.
En la hoja "CONTABILIDAD" como ejemplo también he resaltado en color rojo la fila donde se encuentra el RFC que coincide con la consulta.
Nota: He enviado a su correo el archivo.
Va el código:
Option Explicit
Dim cargando As Boolean
Dim sh1 As Worksheet
'
Private Sub ComboBox1_Change()
'Por.Dante Amor
Dim dato As Variant, fila As Variant
Dim i As Long, j As Long, k As Long, n As Long
Dim a As Variant, ky As Variant, b As Variant
Dim dic As Object
Dim f As Range
Dim sh2 As Worksheet
'
Application.ScreenUpdating = False
If cargando = True Then Exit Sub
Set sh1 = Sheets("BD")
Set sh2 = Sheets("CONTABLIDAD")
Set dic = CreateObject("Scripting.Dictionary")
cargando = True
dato = ComboBox1.Value
ComboBox1.Clear
Range("D6:D15, E6, O5, D16, O16, L17").Value = ""
'
a = sh1.Range("B2:I" & sh1.Range("B" & Rows.Count).End(3).Row).Value
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
For i = 1 To UBound(a, 1)
If a(i, 1) <> "" Then
If Not dic.exists(a(i, 1)) Then
'k = k + 1
dic(a(i, 1)) = i
Else
dic(a(i, 1)) = dic(a(i, 1)) & "|" & i
End If
End If
Next
For Each ky In dic.keys
If UCase(ky) Like "*" & UCase(dato) & "*" Then
ComboBox1.AddItem ky
End If
Next
ComboBox1.Value = dato
'
'Se activa una celda para que aparezca el combo completo
Range("Z1000"). Activate
ComboBox1. Activate
ComboBox1. DropDown
'
Range("B6").Value = ComboBox1.Value
If ComboBox1.ListIndex > -1 Then
n = 6
For Each fila In Split(dic(ComboBox1.Value), "|")
If n = 6 Then
Range("E6").Value = a(fila, 2) 'nombre
Range("O5").Value = a(fila, 8) 'folio
Range("D16").Value = a(fila, 5) 'concepto
Range("O16").Value = a(fila, 6) 'Forma
Range("D6").Value = a(fila, 3) 'factura
Else
Range("D" & n).Value = a(fila, 3) 'factura
End If
Range("L17").Value = Range("L17").Value + a(fila, 4) 'Importe
n = n + 1
Next
Set f = sh2.Range("A:A").Find(ComboBox1.Value, , xlValues, xlWhole, , , False)
If Not f Is Nothing Then
Range("B20:P20").Copy
sh2.Range("K" & f.Row).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
Range("D6").Select
End If
cargando = False
Application.ScreenUpdating = True
End Sub
'
Private Sub ComboBox1_DropButtonClick()
If cargando = True Then Exit Sub
ComboBox1.Value = ""
End Sub
Buenos días Dante Amor, espero que te encuentres muy bien, te quiero comentar que la macro anterior funciona bien, pero en el caso de que también quisiera copiar el rango de varias celdas discontinuas, por ejemplo: el RFC, NOMBRE, FECHA, FOLIO, CONCEPTO DE PAGO, FORMA DE PAGO, IMPORTE que se encuentran en las celdas B6, E6,O5,06,D16,O16, L17
¿Cómo debo modificar esta parte de tu código para indicarle que me copie las celdas que contienen los datos arriba mencionados?
Set f = sh2.Range("A:A").Find(ComboBox1.Value, , xlValues, xlWhole, , , False)
If Not f Is Nothing Then
Range("B20:P20").Copy
sh2.Range("K" & f.Row).PasteSpecial xlPasteValues
Application.CutCopyMode = FalseEsta duda surge a raíz de una necesidad que me surgió hace un par de días para llenar un nuevo formato, he realizado la pregunta en el foro para solicitar tu ayuda, pero bastaría con que me mostraras con este mismo ejemplo para adaptarlo a mi problema actual y resolverlo, gracias por tu ayuda.
Te envié la macro en tu pregunta:
