Copying table data to another sheet dynamically

[devofish]

I have a macro that pastes table data into another worksheet. The code is obviously incomplete.

The problem is that each time I execute the sub, the routine duplicates the table data, inserting the data into the worksheets defined last row. Can anybody help me?

How can I stop it from duplicating the table data into the worksheet?

I've listed the cells on the worksheet for reference
B15 = "Formations"
B21 = "Samples"
B19 = first row of data

Option Explicit

Sub PasteprogData()
Dim sws As Worksheet, dws As Worksheet
Dim tbl As ListObject
Dim cell As Range, CodeCell As Range
Dim dlr As Long
Dim chkStr As String

Application.ScreenUpdating = False
Set sws = Sheets("prog")
Set dws = Sheets("email")
Set tbl = sws.ListObjects("ProgTable")

'check to see if table data exists and if so copy paste (insert) values to email worksheet
For Each cell In tbl.DataBodyRange.Columns(7).Cells
     
    'if table value exists then set string value to row data
    If cell <> "" Then
        chkStr = cell.Offset(0, -4).Value & cell.Value & cell.Offset(0, 1).Value & cell.Offset(0, 3).Value
         
         'having some difficulties reconciling the function
         If Not TopFound(chkStr) Then
            Set CodeCell = dws.Range("B:B").Find(what:="Samples", lookat:=xlWhole)
            If CodeCell.End(xlUp).Value = "Formations" Then
                
                'if the lastrow equals the header then no data is inserted
                dlr = CodeCell.End(xlUp).Offset(4).Row
            Else
                 
                'if string exists insert table data starting at codecell value + 1
                dlr = CodeCell.End(xlUp).Row + 1
                dws.Rows(dlr).Insert
            End If
             
            'after insert paste table data
            dws.Range("B" & dlr).Value = cell.Offset(0, -4).Value
            dws.Range("D" & dlr).Value = cell.Value
            dws.Range("E" & dlr).Value = cell.Offset(0, 1).Value
            dws.Range("F" & dlr).Value = cell.Offset(0, 3).Value
        End If
    End If
Next cell
Application.ScreenUpdating = True
End Sub


Function TopFound(vStr As String) As Boolean

Dim ws As Worksheet
Dim lr As Long
Dim Rng As Range, cell As Range, FirstCell As Range, NextCell As Range
Dim str As String

Set ws = Sheets("email")

Set FirstCell = ws.Range("B:B").Find(what:="Formations", after:=ws.Range("B19"), lookat:=xlWhole)
If FirstCell Is Nothing Then Exit Function
Set FirstCell = FirstCell.Offset(4, 0)

If FirstCell.Value = "" Then Exit Function

Set NextCell = ws.Range("B:B").Find(what:="Samples", lookat:=xlWhole)
If Not NextCell Is Nothing Then
    If NextCell.End(xlUp).Value = "Formations" Then
        lr = NextCell.End(xlUp).Offset(4).Row
    Else
        lr = NextCell.End(xlUp).Row
    End If
    
    Set Rng = ws.Range(FirstCell, ws.Cells(lr, 2))
    For Each cell In Rng
        str = cell.Value & cell.Offset(0, 1).Value & cell.Offset(0, 6).Value 'errors on this code when str's value is changed
        If LCase(str) = LCase(vStr) Then
            TopFound = True
            Exit Function
        End If
        
    Next cell
Else
    TopFound = True
End If
End Function

 

[Zack Barresse]

Can you give a detailed description of what you're trying to achieve here? I see your code, but not sure how your Tables are structured, or the desired result. Is the destination a Table as well?

 

[devofish]

Hi Zach,

I have 2 sheets (prog, email). The source sheet (prog) contains a table (A:J). The columns (B,D:F) within the destination sheet (email) is not a table. The relationships are such that:

Sheets("prog").Range("C") = Sheets("email").Range("B").....in the sub--> cell.Offset(0, -4).Value
Sheets("prog").Range("G") = Sheets("email").Range("D").....in the sub--> cell.Value
Sheets("prog").Range("H") = Sheets("email").Range("E").....in the sub--> cell.Offset(0, 1).Value
Sheets("prog").Range("J") = Sheets("email").Range("F").....in the sub--> cell.Offset(0, 3).Value

Note that Range("G") within the tbl is what is tested <>""

For Each cell In tbl.DataBodyRange.Columns(7).Cells

Every 12 hours, a user generates a report (from email). Days pass sometimes before a new value is input into the prog table. As it is now, the code keeps duplicating the source data (to the last row) within the destination columns every time the code runs.

I can't figure out why my function won't compare the values of the destination cells with the source table data and append the destination values if source data was added or deleted, or exit sub because the match is true.