Paste Data From Table A To Table B's First Row, Shifting Existing Data Down

[excelakos]

Hi dear all
I need to achieve the following string of actions

Filter specific value in a specific column in table A
Copy the filtered data range from table A (not the headers)
Go to a different sheet in the same workbook
Paste the copied data in the first row of table B, moving any existing rows of data down.

Actual Sheet and Table names

Sheet: PasteSiteData, Table: t_copypaste
Sheet: StakesArchive, Table: t_stakesarchive

I am trying to achieve this with the following code:

Sub PasteSiteData_SendToArchive()


ActiveSheet.ListObjects("t_copypaste").Range.AutoFilter Field:=36, Criteria1 _
        :="<>|"

Dim tbl As ListObject
    Set tbl = ActiveSheet.ListObjects("t_copypaste")
    
    Dim Rng As Range
    Set Rng = tbl.DataBodyRange
    Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1)

Dim r As Long

With Sheets("StakesArchive").ListObjects("t_stakesarchive")
  For r = 2 To Rng.Rows.Count
    .ListRows.Add (1)
  Next r
  With .DataBodyRange
    Rng.Copy
    .Cells(1).PasteSpecial Paste:=xlPasteValues
    .Cells(Rng.Rows.Count + 1, .Columns.Count).Copy
    .Cells(1, .Columns.Count).PasteSpecial Paste:=xlPasteFormulas
  End With
End With
Application.CutCopyMode = False
End Sub

The result is almost achieved except that in table "t_stakesarchive" the above code adds as many extra rows as the actual count of rows in table "t_copypaste" but I want to add only as many rows as the filtered ones.
I can imagine that part of the issue probably exists in the following line:

 Set Rng = tbl.DataBodyRange

Thank you in advance

 

[Alex Blakenburg]

Try changing this line:

  For r = 2 To Rng.Rows.Count

To this:

      For r = 1 To Rng.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count

By the way, are you intentionally not copying the first data row of the copypaste table ?
If it is not intentional then remove this line:

        Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1)

 

[excelakos]

Try changing this line:

  For r = 2 To Rng.Rows.Count

To this:

      For r = 1 To Rng.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count

By the way, are you intentionally not copying the first data row of the copypaste table ?
If it is not intentional then remove this line:

        Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1)

Thank you very much, Alex. Now the macro works just fine. One little thing though. When the target table is empty, meaning we have the headers plus one row but with no data, the result we get is that this empty row is kept after the pasting (as the final row of the table with no data). Is there any way to address this issue of the very first paste? Thank you in advance

 

[Alex Blakenburg]

By the way, are you intentionally not copying the first data row of the copypaste table ?
If it is not intentional then remove this line:

I didn't get a reply on the above so hopefully you just removed the line. I have removed it in the below code.

When the target table is empty, meaning we have the headers plus one row but with no data, the result we get is that this empty row is kept after the pasting (as the final row of the table with no data). Is there any way to address this issue of the very first paste? Thank you in advance

Give this a try. I have also added error trapping for the filter not returning any rows.

Sub PasteSiteData_SendToArchive()
  
    ActiveSheet.ListObjects("t_copypaste").Range.AutoFilter Field:=36, Criteria1 _
            :="<>|"
    
    Dim tbl As ListObject
    Set tbl = ActiveSheet.ListObjects("t_copypaste")
    
    Dim Rng As Range
    Set Rng = tbl.DataBodyRange
    
    Dim tblArch
    Set tblArch = Worksheets("StakesArchive").ListObjects("t_stakesarchive")
    
    Dim r As Long
    Dim rowsVisible As Long
    Dim emptyRowArch As String
    
    On Error Resume Next
        ' check if filtered data contains no results rows
        rowsVisible = Rng.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count
        If Err <> 0 Then Exit Sub
    On Error GoTo 0
    
    ' check if ArchiveTable has a databody with a single empty row
    ' this is different not having a databody range
    emptyRowArch = "N"
    If tblArch.ListRows.Count = 1 Then
        If Application.CountA(tblArch.ListRows(1).Range) = 0 Then
            emptyRowArch = "Y"
        End If
    End If
    
    With tblArch
      For r = 1 To Rng.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count
        If emptyRowArch <> "Y" Then
            .ListRows.Add (1)
        Else
             emptyRowArch = "N"
        End If
      Next r
      With .DataBodyRange
        Rng.Copy
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(Rng.Rows.Count + 1, .Columns.Count).Copy
        .Cells(1, .Columns.Count).PasteSpecial Paste:=xlPasteFormulas
      End With
    End With
    Application.CutCopyMode = False
End Sub

 

[excelakos]

I didn't get a reply on the above so hopefully you just removed the line. I have removed it in the below code.


Give this a try. I have also added error trapping for the filter not returning any rows.

Sub PasteSiteData_SendToArchive()
 
    ActiveSheet.ListObjects("t_copypaste").Range.AutoFilter Field:=36, Criteria1 _
            :="<>|"
   
    Dim tbl As ListObject
    Set tbl = ActiveSheet.ListObjects("t_copypaste")
   
    Dim Rng As Range
    Set Rng = tbl.DataBodyRange
   
    Dim tblArch
    Set tblArch = Worksheets("StakesArchive").ListObjects("t_stakesarchive")
   
    Dim r As Long
    Dim rowsVisible As Long
    Dim emptyRowArch As String
   
    On Error Resume Next
        ' check if filtered data contains no results rows
        rowsVisible = Rng.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count
        If Err <> 0 Then Exit Sub
    On Error GoTo 0
   
    ' check if ArchiveTable has a databody with a single empty row
    ' this is different not having a databody range
    emptyRowArch = "N"
    If tblArch.ListRows.Count = 1 Then
        If Application.CountA(tblArch.ListRows(1).Range) = 0 Then
            emptyRowArch = "Y"
        End If
    End If
   
    With tblArch
      For r = 1 To Rng.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count
        If emptyRowArch <> "Y" Then
            .ListRows.Add (1)
        Else
             emptyRowArch = "N"
        End If
      Next r
      With .DataBodyRange
        Rng.Copy
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(Rng.Rows.Count + 1, .Columns.Count).Copy
        .Cells(1, .Columns.Count).PasteSpecial Paste:=xlPasteFormulas
      End With
    End With
    Application.CutCopyMode = False
End Sub

Thank you again for your time and interest. Unfortunately, we didn't get the wanted result. Again if it is the first-ever time we transfer data to the archive table the originally existing (and empty) data row is being kept as the last row of the table. I addressed it by adding the following part of code at the end. But I would like to have a solution like the one you tried, I consider it more "professional"

I don't know VBA myself, I am just a user of ready parts of coding

Dim iCntr As Long


Set Rng = ActiveSheet.ListObjects("t_stakesarchive").Range

For iCntr = Rng.Row + Rng.Rows.Count - 1 To Rng.Row Step -1
        If Application.WorksheetFunction.CountA(Rows(iCntr)) <= 37 Then Rows(iCntr).EntireRow.Delete
    Next

 

[Alex Blakenburg]

There are a few ways of getting a blank row on an apparently empty table and they behave differently when checking for it.

1) The following will show a blank row but the Table won't have a databody range

• Creating a table with only 1 row selected and the has headers option checked
• Select "ALL" the rows below the heading on an existing table and delete the rows
  
  In this instance tblArch.ListRows.Count will return 0
  (databody range does not exist and trying to set it will error out)

2) The following will show a blank row but that row will be the Tables databody range

• Create a table with 2 rows selected and the has headers option checked
• Delete all rows except 1 and clear the contents of the remaining row
  
  In this instance tblArch.ListRows.Count will return 1

In option 2 above the issue now becomes it says you have 1 row BUT IS IT EMPTY.
If there are no formulas or values you can use COUNTA = 0 but if you have some formulas in it COUNTA will be greate than 0.
The test If Application.WorksheetFunction.CountA(Rows(iCntr)) <= 37 requires every column in the line to be empty.
That is pretty agressive and you could lose data since it will delete the line if even 1 field is left blank.
It does need some thought on when the line can be considered blank though, ie maybe if certain key fields are blank.

It should only be an issue if the table contains formulas though or the row has not been cleared down properly.