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

excelakos

Board Regular
Joined
Jan 22, 2014
Messages
85
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:

VBA 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:

VBA Code:
 Set Rng = tbl.DataBodyRange


Thank you in advance
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Try changing this line:
VBA Code:
  For r = 2 To Rng.Rows.Count

To this:
VBA Code:
      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:
VBA Code:
        Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1)
 
Upvote 0
Solution
Try changing this line:
VBA Code:
  For r = 2 To Rng.Rows.Count

To this:
VBA Code:
      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:
VBA Code:
        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
 
Upvote 0
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.

VBA 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
    
    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
 
Upvote 0
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.

VBA 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
   
    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

VBA Code:
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
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,223,886
Messages
6,175,196
Members
452,616
Latest member
intern444

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top