如果表格范围内的单元格值等于“新建”，则复制整行并粘贴为工作表 1 中下一个空单元格中的值

Question

I am trying to do a basic thing but cannot get it right.

I want to evaluate the cells on sheet 2(New Roster) in a table column(OldNew) for the value "New". If it has the value, copy the entire row and add it to the table(CurrentRoster) on sheet 1(Current Roster).

Here is the code I am using:

For Each c In wb.Names("OldNew").RefersToRange.Cells
    If c.Value Like "New" Then
        On Error Resume Next
        Set SourceTable = Worksheets("New Roster").ListObjects("NewRoster").DataBodyRange
        Set DestinationTable = Worksheets("Current Roster").ListObjects("CurrentRoster").ListRows.Add
        SourceTable.Copy
        DestinationTable.Range.PasteSpecial xlPasteValues
    End If
Next

This endlessly loops and does not do what I want.

Here is the entire code for context: Sub TableData()

Dim tbl As ListObject Dim cell As Range Dim rng As Range Dim RangeName As String Dim CellName As String Dim wb As Workbook, c As Range, m Dim ws1 As Worksheet Dim lr As Long Dim lo As ListObject Dim SourceTable Dim DestinationTable

Worksheets("New Roster").Activate Range("A1").Select

If Range("A1") = "" Then
     MsgBox "No Data to Reconcile"
     Exit Sub
    Else
 End If

Application.ScreenUpdating = False  '---->Prevents screen flickering as the code executes.
Application.DisplayAlerts = False  '---->Prevents warning "pop-ups" from appearing.

 ' Clears hidden columns from previous user
Worksheets("Current Roster").Activate
Range("A1").Activate
Columns.EntireColumn.Hidden = False

On Error Resume Next
 Sheet1.ShowAllData
On Error GoTo 0

' Tables the New Roster
Worksheets("New Roster").Activate
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name _
= "NewRoster"
Range("NewRoster[#All]").Select
ActiveSheet.ListObjects("NewRoster").TableStyle = ""

' Name Ranges for Reference, New Name List From New Roster
ActiveSheet.Range("F2").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Names.Add Name:="NewNameList", RefersToR1C1:= _
"=NewRoster[Member AHCCCS ID]"
ActiveWorkbook.Names("NewNameList").Comment = "Contains New list to compare old list to"


' Compares CurrentNameList Values to NewNameList Values to verify if current names are still active
Set wb = ThisWorkbook
For Each c In wb.Names("CurrentNameList").RefersToRange.Cells
    m = Application.Match(c.Value, wb.Names("NewNameList").RefersToRange, 0)
    c.Offset(0, 26).Value = IIf(IsError(m), "InActive", "Active")
Next c

' Adds Column to New Roster Table and place Old/New in header cell
Worksheets("New Roster").Activate
Worksheets("New Roster").Range("AF1").Value = "Old/New"

' Names Old/New Range
ActiveSheet.Range("AF1").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Names.Add Name:="OldNew", RefersToR1C1:= _
"=NewRoster[Old/New]"
ActiveWorkbook.Names("OldNew").Comment = ""

' Compares CurrentNameList Values to NewNameList Values to determine if New Name, If so, Add to Current 
Roster
For Each c In wb.Names("NewNameList").RefersToRange.Cells
    m = Application.Match(c.Value, wb.Names("CurrentNameList").RefersToRange, 0)
    c.Offset(0, 26).Value = IIf(IsError(m), "New", "Old")
Next c
    
' Move Rows with "New" from New Roster to Current Roster Worksheet
Worksheets("New Roster").Activate

For Each c In wb.Names("OldNew").RefersToRange.Cells
    If c.Value Like "New" Then
        On Error Resume Next
        Set SourceTable = Worksheets("New Roster").ListObjects("NewRoster").DataBodyRange
        Set DestinationTable = Worksheets("Current Roster").ListObjects("CurrentRoster").ListRows.Add
        SourceTable.Copy
        DestinationTable.Range.PasteSpecial xlPasteValues
    End If
Next
    
 ' Clear New Roster Data
Worksheets("New Roster").Activate
Columns("A:A").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlToLeft
ActiveWorkbook.Names("NewNameList").Delete
ActiveWorkbook.Names("OldNew").Delete
Worksheets("Current Roster").Activate
Range("A1").Activate
ActiveSheet.Range("CurrentRoster[#All]").RemoveDuplicates Columns:=Array(1, 2, _
3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 
30, 31 _
, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55), _
Header:=xlYes



Application.DisplayAlerts = True   '---->Resets the default.
Application.ScreenUpdating = True  '---->Resets the default.


End Sub

Answer 1

Copy From Table to Table

• Remove the duplicate declarations and references.
• This will only work if both tables have the same number of columns and table NewRoster has a column with the header OldNew .
• It's a standalone version, so you can test it as is. Later you just have to delete the added rows.
• If you want to allow case-insensitivity (allow new,NEW), you can add vbTextCompare as the fourth argument in the Instr function.
• Forget about On Error Resume Next . Approximately: It is usually (exclusively) used on one (a few) lines and is 'ended' with an On Error Goto 0 or with some error handling, eg If Err then which will again contain On Error Goto 0 or some other On Error statement. There's a lot more to it. You should know exactly why you are using it.

The Code

Sub copyFromTableToTable()
    Dim wb As Workbook
    Set wb = ThisWorkbook
    With wb.Worksheets("New Roster").ListObjects("NewRoster")
        Dim c As Range
        Dim dest As Range
        Dim hRow As Long
        hRow = .HeaderRowRange.Row
        For Each c In .ListColumns("OldNew").DataBodyRange
            If InStr(1, c.Value, "New") > 0 Then
                With wb.Worksheets("Current Roster").ListObjects("CurrentRoster")
                    ' This doesn't work.
                    'Set dest = .ListRows.Add
                    .ListRows.Add
                    With .DataBodyRange
                        Set dest = .Rows(.Rows.Count)
                    End With
                End With
                dest.Value = .DataBodyRange.Rows(c.Row - hRow).Value
            End If
        Next c
    End With
End Sub