Copy values from one woorkbook to another according to cell location

Hello!

Currently what my code does is that it copies the corresponding values "value 1", "value 2" and "value 3" in regards to the respective "ID" from WorkbookA. It then pastes the values to WorkbookB in the corresponding Sheets. The code compares the ID from WorkbookA with the IDs from WorkbookBs sheets. When the ID fits it pastes the values into the respective cells. It then proceeds to the next ID (see attachments).

What I want my code to do instead, is still to copy the values from WorkbookA into their respective places in the corresponding sheet. But the values should now be pasted into 1 column, instead of 3 (see attachment: WorksheetC). The cells for which the numbers should be copied to, are always G10, G16 and G19 for all the "Test person" sheets.

An example: The values 5, 8 and 12 for IG1 in WorkbookA should be pasted into the cells G10, G16 and G19 respectively in WorkbookC, under sheet "Test person 1", as the IDs correspond (thus replacing the values 32, 44 and 22).

Is there a way for the code to paste the values into their respective cells, just based on cell position?


CODE:

Sub Demo()
Dim cn As Object, rst As Object
Dim strQuery As String
Dim ws As Worksheet

Set cn = CreateObject("ADODB.Connection")
With cn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .ConnectionString = "Data Source=" & ThisWorkbook.Path & "\WorkbookA.xlsx;" & _
                        "Extended Properties=""Excel 12.0 Xml;HDR=Yes:"""
    .CursorLocation = 3
    .Open
End With

For Each ws In ThisWorkbook.Worksheets
    strQuery = "SELECT [Value 1], [Value 2], [Value 3] FROM [Sheet1$] WHERE [ID:] = """ & ws.[B1].Value & """"

    Set rst = CreateObject("ADODB.Recordset")
    rst.Open strQuery, cn, 1, 3
    
    If rst.RecordCount > 0 Then
        ws.Range("D2").CopyFromRecordset rst
    End If
Next

rst.Close
cn.Close

End Sub

Thanks!