Trouble pasting row to table

问题

For every cell that is not blank in column "Transition" of table "TableQueue", I want to:
1)Copy from table "TableQueue" the entire table row that contains that cell, 2)Paste that row to the bottom of table "TableNPD", 3)Delete the row from table "TableQueue"

I've gotten everything except the copy/paste/delete to work. See my note halfway down the code below to see where my problem begins. I am new to vba and, although I can find plenty of info on copying and pasting to the bottom of a table, its all slightly different from each other and different from how I've already set up the top half of my code. I need the solution to make as few changes as possible to what I've already set up;...I won't be able to understand anything largely different.

Sub Transition_from_Queue2()

Dim QueueSheet As Worksheet
Set QueueSheet = ThisWorkbook.Sheets("Project Queue")   

Dim QueueTable As ListObject
Set QueueTable = QueueSheet.ListObjects("TableQueue")

Dim TransColumn As Range
Set TransColumn = QueueSheet.Range("TableQueue[Transition]")

Dim TransCell As Range
Dim TransQty As Double

    For Each TransCell In TransColumn
        If Not IsEmpty(TransCell.Value) Then
            TransQty = TransQty + 1
        End If
    Next TransCell

Dim TransAnswer As Integer

If TransQty = 0 Then
    MsgBox "No projects on this tab are marked for transition."
        Else
        If TransQty > 0 Then
            TransAnswer = MsgBox(TransQty & " Project(s) will be transitioned from this tab." & vbNewLine & "Would you like to continue?", vbYesNo + vbExclamation, "ATTEMPT - Project Transition")
                If TransAnswer = vbYes Then

'Add new row to NPD table
                    For Each TransCell In TransColumn
                        If InStr(1, TransCell.Value, "NPD") > 0 Then
                            Dim Trans_new_NPD_row As ListRow
                            Set Trans_new_NPD_row =     ThisWorkbook.Sheets("NPD").ListObjects("TableNPD").ListRows.Add

'I GOT EVERYTHING ABOVE HERE TO WORK. MY PROBLEM IS WITH EVERYTHING BELOW HERE.

                            'Copy Queue, paste to NPD, and Delete from Queue
                            Dim TransQueueRow As Range
                            Set TransQueueRow = TransCell.Rows
                            TransQueueRow.Copy
                            Dim LastPasteRow As Long
                            Dim PasteCol As Integer
                                With Worksheets("NPD")
                                    PasteCol = .Range("TableNPD").Cells(1).Column
                                    LastPasteRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
                                End With
                            ThisWorkbook.Worksheets("NPD").Cells(LastPasteRow, PasteCol).PasteSpecial xlPasteValues

回答1:

Trans_new_NPD_row.Range is the range for the new row you just added, so you should be able to use something like

Set Trans_new_NPD_row = ThisWorkbook.Sheets("NPD").ListObjects("TableNPD").ListRows.Add 

Trans_new_NPD_row.Range.Value = _
         Application.Intersect(TransCell.EntireRow, QueueTable.DataBodyRange).Value

EDIT: here's a working example of moving rows from one table to another, using the listobject/table methods

Sub tester()

    Dim tblQueue As ListObject, tblNPD As ListObject, c As Range, rwNew As ListRow
    Dim rngCol As Range, n As Long

    Set tblQueue = Sheet1.ListObjects("Queue")  '<< source table
    Set tblNPD = Sheet2.ListObjects("TableNPD") '<< destination table

    Set rngCol = tblQueue.ListColumns("Col3").DataBodyRange

    'loop from the bottom to the top of the source table
    For n = tblQueue.ListRows.Count To 1 Step -1
        'move this row?
        If rngCol.Cells(n) = "OK" Then
            Set rwNew = tblNPD.ListRows.Add
            rwNew.Range.Value = tblQueue.ListRows(n).Range.Value
            tblQueue.ListRows(n).Delete
        End If
    Next n

End Sub

Source table (destination has the same format):

来源：https://stackoverflow.com/questions/56996550/trouble-pasting-row-to-table

标签

excel

vba

paste

listobject