Copy and paste same values from 2 columns

I was hoping to be able to have a macro that would be able to extract the ID from each of our orders and put them into table 3.

Lookup Data (Excel Tables)

Option Explicit

Sub LookupData()
       
    Const lName As String = "Sheet1"
    Const ltName As String = "Table1"
    Const lcName As String = "Table 1"
    
    Const sName As String = "Sheet1"
    Const stName As String = "Table2"
    Const sclName As String = "Table 2"
    Const scvName As String = "ID"
    
    Const dName As String = "Sheet2"
    Const dtName As String = "Table3"
    Const dclName As String = "Table 3 (RESULTS)"
    Const dcvName As String = "ID"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Lookup
    Dim lws As Worksheet: Set lws = wb.Worksheets(lName)
    Dim ltbl As ListObject: Set ltbl = lws.ListObjects(ltName)
    Dim lrCount As Long: lrCount = ltbl.Range.Rows.Count
    Dim lcl As ListColumn: Set lcl = ltbl.ListColumns(lcName) ' Lookup Column
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim stbl As ListObject: Set stbl = sws.ListObjects(stName)
    Dim scl As ListColumn: Set scl = stbl.ListColumns(sclName)
    Dim slrg As Range: Set slrg = scl.DataBodyRange ' Lookup Column
    Dim scv As ListColumn: Set scv = stbl.ListColumns(scvName)
    Dim svrg As Range: Set svrg = scv.DataBodyRange
    Dim svData As Variant: svData = svrg.Value ' Value Array
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dtbl As ListObject: Set dtbl = dws.ListObjects(dtName)
    Dim drCount As Long: drCount = dtbl.Range.Rows.Count
    Dim dcl As ListColumn: Set dcl = dtbl.ListColumns(dclName) ' written to
    Dim dcv As ListColumn: Set dcv = dtbl.ListColumns(dcvName) ' written to
    
    ' Copy lookup column.
    dcl.DataBodyRange.Resize(lrCount - 1).Value = lcl.DataBodyRange.Value
    
    Dim lData As Variant: lData = lcl.DataBodyRange.Value ' Lookup Array
    Dim dvData As Variant: ReDim dvData(1 To lrCount - 1, 1 To 1) ' Value Array
    
    Dim sIndex As Variant
    Dim r As Long
    
    ' Match value data.
    For r = 1 To lrCount - 1
        sIndex = Application.Match(lData(r, 1), slrg, 0)
        If IsNumeric(sIndex) Then
            dvData(r, 1) = svData(sIndex, 1)
        End If
    Next r
    
    ' Copy value array to value range.
    dcv.DataBodyRange.Value = dvData
    
    If lrCount < drCount Then
        ' Resize and clear.
        dtbl.Resize dtbl.Range.Resize(lrCount)
        dtbl.DataBodyRange.Resize(drCount - lrCount).Offset(lrCount - 1).Clear
    End If
    
End Sub