Сохранить тип данных с помощью варианта прямой передачи значения

Может быть, что-то вроде этого:

Sub CopyOverMatches()

    Dim tbl1 As ListObject, tbl2 As ListObject
    Dim h As ListColumn, h2 As ListColumn, data

    Set tbl1 = ActiveSheet.ListObjects("Table1")
    Set tbl2 = ActiveSheet.ListObjects("Table2")

    'loop over the headers from the source table
    For Each h In tbl1.ListColumns

        'is there a column of the same name in the destination table?
        Set h2 = Nothing
        On Error Resume Next
        Set h2 = tbl2.ListColumns(h.Name)
        On Error GoTo 0

        If Not h2 Is Nothing Then '<< have a matching column

            data = h.DataBodyRange.Value

            With h2.DataBodyRange.Cells(1).Resize(UBound(data, 1), 1)
                .NumberFormat = h.DataBodyRange(1).NumberFormat
                .Value = data
            End With

        End If
    Next h

End Sub