¿Cómo insertar datos de una hoja a otra con base al ID de consulta?

Dame oportunidad de revisar el archivo y regreso aquí con la respuesta.

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 = False

Esta 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.