Help with this loop only first row works

[kapela2017]

Greetings, I have a problem relating these two tables, using the "ID" column I did it through a loop, it should take the data from the "Source Table" according to the ID and take it to the "Goal Table", but it only relates the first row the other rows of the "Goal Table" remain in their fields are empty, below I leave the 2 tables and the code any help would be greatly appreciated

SolutionXLookup.xlsm
	A	B	C	D
1	ID	PRODUCT	WEIGHT	COST
2	1001	APPLE	0,2 KG	2,3$
3	1002	PEAR	4,5 KG	3,1$
4	1003	PEACH	5.4 KG	2,1$
5	1004	STRAWBERRY	2,9 KG	3,4$
6	1005	CANTAOLUPE	49 KG	4,1$
7	1006	MANGO	2.4 KG	3,2$
8	1007	ORANGE	5,9 KG	1,4$
9	1008	Banana	8,5 KG	3,2$
SourceData

SolutionXLookup.xlsm
	A	B	C	D	E	F	G	H
1	ID	PRODUCT	WEIGHT	COST
2	1007	APPLE	5,9 KG	1,4$
3	1002	PEAR
4	1003	PEACH
5	1004	STRAWBERRY
6
7
8
9
10
GoalTable

[CODE=vba][CODE=vba]Option Explicit

Sub CopyData()

Dim wsSourceData As Worksheet
Dim wsGoalTable As Worksheet

Set wsSourceData = ThisWorkbook.Sheets("SourceData")
Set wsGoalTable = ThisWorkbook.Sheets("GoalTable")

Dim SrcTable As ListObject
Set SrcTable = wsSourceData.ListObjects("Source") 'rename

Dim GoalTable As ListObject
Set GoalTable = wsGoalTable.ListObjects("Goal")


Dim a As Object
Dim b As Object
Dim SrcLen As Integer
Dim CounterSrc As Integer
Dim CounterGoal As Integer


SrcLen = SrcTable.ListColumns("ID").DataBodyRange.Rows.Count

CounterSrc = 1
CounterGoal = 1

For Each a In GoalTable.ListColumns("ID").DataBodyRange

    For Each b In SrcTable.ListColumns("ID").DataBodyRange
        If Str(a) = Str(b) Then
            GoalTable.DataBodyRange(CounterGoal, 3).Value = SrcTable.DataBodyRange(CounterSrc, 3).Value 'Weight
            GoalTable.DataBodyRange(CounterGoal, 4).Value = SrcTable.DataBodyRange(CounterSrc, 4).Value 'Cost
        End If
        CounterSrc = CounterSrc + 1
    Next

CounterGoal = CounterGoal + 1
Next


End Sub

[/CODE][/CODE]

 

[dmt32]

Hi,
see if this update to your code does what you want

Option Explicit

Sub CopyData()
    Dim SrcTable    As ListObject, GoalTable As ListObject
    Dim SourceArr   As Variant, ID As Variant, m As Variant
    Dim i           As Long
    
    With ThisWorkbook
        Set SrcTable = .Worksheets("SourceData").ListObjects("Source")
        Set GoalTable = .Worksheets("GoalTable").ListObjects("Goal")
    End With
    
    SourceArr = SrcTable.DataBodyRange.Value
    
    For i = 1 To UBound(SourceArr, xlRows)
        ID = SourceArr(i, 1)
        m = Application.Match(ID, GoalTable.ListColumns("ID").DataBodyRange, 0)
        If Not IsError(m) Then
            With GoalTable
                .DataBodyRange(CLng(m), 3).Value = SourceArr(i, 3)
                .DataBodyRange(CLng(m), 4).Value = SourceArr(i, 4)
            End With
        End If
    Next i
    
End Sub

Dave

 

[kapela2017]

Hi,
see if this update to your code does what you want

Option Explicit

Sub CopyData()
    Dim SrcTable    As ListObject, GoalTable As ListObject
    Dim SourceArr   As Variant, ID As Variant, m As Variant
    Dim i           As Long
   
    With ThisWorkbook
        Set SrcTable = .Worksheets("SourceData").ListObjects("Source")
        Set GoalTable = .Worksheets("GoalTable").ListObjects("Goal")
    End With
   
    SourceArr = SrcTable.DataBodyRange.Value
   
    For i = 1 To UBound(SourceArr, xlRows)
        ID = SourceArr(i, 1)
        m = Application.Match(ID, GoalTable.ListColumns("ID").DataBodyRange, 0)
        If Not IsError(m) Then
            With GoalTable
                .DataBodyRange(CLng(m), 3).Value = SourceArr(i, 3)
                .DataBodyRange(CLng(m), 4).Value = SourceArr(i, 4)
            End With
        End If
    Next i
   
End Sub

Dave

Hello friend, your code works perfectly, thank you very much for your valuable contribution...

 

[dmt32]

Hello friend, your code works perfectly, thank you very much for your valuable contribution...

most welcome & appreciate your feedback

Dave