Copy multiple value with same headers from one workbook to another

I have two workbook. One workbook has several smaller tables, each tables has the same header labels in Column A, and value for some data starting from Column B, Below is a sample of how the table looks like: The other workbook has the same small tables, header labels and region name. but has no value for the data. I want to develop a program to automate the task of copying the corresponding value from the first workbook to the other one, the row in the source workbook is not fixed because the value are filled out by different people every time and they may not put the data in the same row as before.

I only know how to copy data if the row is fixed, and the current code I have does not copy any data at all:

'Sub CopyTablesData()
Dim srcWorkbook As Workbook
Dim destWorkbook As Workbook
Dim srcSheet As Worksheet
Dim destSheet As Worksheet
Dim srcRange As Range
Dim destRange As Range
Dim lastRow As Long
Dim lastCol As Long
Dim tableStart As Range
Dim tableEnd As Range

' Set the workbooks
Set srcWorkbook = Workbooks("Test Sour.xlsm")
Set destWorkbook = Workbooks("Test Dest.xlsx")

' Loop through each sheet in the source workbook
For Each srcSheet In srcWorkbook.Sheets
    ' Set the corresponding sheet in the destination workbook
    Set destSheet = destWorkbook.Sheets("Summary")
    
    ' Find the first cell with data in the source sheet
    Set tableStart = srcSheet.Cells.Find(What:="*", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
    
    ' Find the last cell with data in the source sheet
    Set tableEnd = srcSheet.Cells.Find(What:="*", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    
    ' Check if any data is found
    If Not tableStart Is Nothing And Not tableEnd Is Nothing Then
        ' Set the range for the source table
        Set srcRange = srcSheet.Range(tableStart, tableEnd)
        
        ' Set the range for the destination table
        Set destRange = destSheet.Range(tableStart.Address, tableEnd.Address)
        
        ' Copy the data from the source to the destination
        srcRange.Copy Destination:=destRange
    End If
Next srcSheet

' Notify the user that the process is complete
MsgBox "Data copied successfully!"
'End Sub

Please let me know if anything else is required, thank you so much for your help in advance

Edit: There are multiple sheets in the source workbook, however I only need to automate one sheet. Region name and header values are present in the destination workbook (with multiple worksheets as well but I only need one sheet to be automated). The destination worksheet looks something like this (the source worksheet also updated to include column labels): These are simply samples, the real worksheets has more region names and header values. They may also change but they will be changed simultaneously by other people on both worksheets.

Solution

Consolidate Data from Multiple in Single Worksheet

Sub CopyTablesData()
    
    ' Define constants.
    Const ROWS_COUNT As Long = 7
    Const COLS_COUNT As Long = 3
    Const ROW_OFFSET As Long = 1
    Const COL_OFFSET As Long = 0
    Const REGION_COLUMN As Long = 2
    Dim REGIONS() As Variant: REGIONS = VBA.Array( _
        "US", "APAC") ' add them all!
    Const DEBUG_PRINT As Boolean = True
    
    ' Create and reference a dictionary object.
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    ' Copy the regions to the keys of the dictionary.
    Dim n As Long:
    For n = 0 To UBound(REGIONS)
        dict(REGIONS(n)) = Empty
    Next n
    
    ' Reference the source workbook.
    Dim swb As Workbook: Set swb = Workbooks("Test Sour.xlsm")
    ' If this is the workbook containing this code,
    ' use 'Set swb = ThisWorkbook' instead.
    
    ' Reference the destination objects.
    Dim dwb As Workbook: Set dwb = Workbooks("Test Dest.xlsx")
    Dim dws As Worksheet: Set dws = dwb.Sheets("Summary") ' set it once!
    Dim drg As Range: Set drg = dws.UsedRange.Columns(REGION_COLUMN)
    
    ' Declare additional variables.
    Dim sws As Worksheet, srg As Range, srrg As Range, scell As Range
    Dim drrg As Range, dcell As Range, sData() As Variant, Region As Variant
    
    ' Find the corresponding regions in the sheets and copy values.
    For Each sws In swb.Worksheets ' 'Sheets' includes charts
        Set srg = sws.UsedRange.Columns(REGION_COLUMN)
        For Each Region In dict.Keys
            ' Find the region cells.
            Set scell = srg.Find(Region, , xlFormulas, xlWhole)
            If Not scell Is Nothing Then
                Set dcell = drg.Find(Region, , xlFormulas, xlWhole)
                If Not dcell Is Nothing Then
                    ' Build the ranges.
                    Set srrg = scell.Offset(ROW_OFFSET, COL_OFFSET) _
                        .Resize(ROWS_COUNT, COLS_COUNT)
                    Set drrg = dcell.Offset(ROW_OFFSET, COL_OFFSET) _
                        .Resize(ROWS_COUNT, COLS_COUNT)
                    ' Copy values.
                    drrg.Value = srrg.Value
                    ' Show what was copied in the Immediate window (CTRL+G).
                    If DEBUG_PRINT Then
                        Debug.Print "Copied " & sws.Name & "!" _
                            & srrg.Address(0, 0) & " to " & dws.Name & "!" _
                            & drrg.Address(0, 0)
                    End If
                    ' Remove the copied region from the dictionary.
                    dict.Remove Region
                End If
            End If
        Next Region
        If dict.Count = 0 Then Exit For
    Next sws
    
    ' Save the destination 'template' workbook with a new name.
    'dws.SaveAs...
    
    ' Inform.
    MsgBox "Data copied.", vbInformation

End Sub