Moving data from one workbook to another

[Allerdrengen]

I have two workbooks: WorkbookA and WorkbookB. (Attached)
I want to copy the values for the person with ID number: IG1 from workbookA to the corresponding sheet in workbookB. The sheet for IG1 would be sheet "Test person 1" as cell B1 in this sheet, contains the corresponding ID (IG1).
There are already values in the cells (32, 7 and 1) in WorkbookB (sheet: test person 1), these values should be replaced by 5, 8 and 12 (from WorkbookA), respectively.

This procedure should then continue for the next ID (IG2), and so forth. If the ID is not found in workbookB, it should skip it, and go to the next ID, until there are no more IDs.

So i need a code that compares the ID from column A in WorkbookA, with its corresponding ID, which is located in one of the "Test person" sheets in workbookB, in cell B1. It should then copy and paste the corresponding values (value 1, value 2 and value 3) that matches the ID, from workbookA, to the cells D2, E2 and F2 in workbookB.

Thank you very much!

[CK76]

I'd use ADO.

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

Save both attached to same folder. And while WorkbookA is closed, run code in WorkbookB.

[Allerdrengen]

Thank you! It works perfectly.

[JOHN H. DAVIS]

Maybe:

Sub Allerdrengen()
Dim i As Long, x As Range, y
With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With
With Workbooks("workbookb.xlsx")
ReDim y(1 To .Sheets.Count)
    For i = LBound(y) To UBound(y)
        Set x = Workbooks("workbooka.xlsx").Sheets("Sheet1").Columns(1).Find(.Sheets(i).Cells(1, 2), LookIn:=xlValues, lookat:=xlWhole)
            If Not x Is Nothing Then
                .Sheets(i).Range("D2").Resize(, 3).Value = x.Offset(, 1).Resize(, 3).Value
            End If
        Set x = Nothing
    Next i
End With
With Application
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With
End Sub

[JOHN H. DAVIS]

You're welcome. Glad to help out and thanks for the feedback and rep. Please mark this thread as SOLVED.