Copy active row and paste as new row in table

[Vbanoob98]

Hi so I have the following code that copies the active row and inserts it as a new row

    ActiveCell.Rows.EntireRow.Select
    Selection.Copy
    ActiveCell.Offset(1, 0).Rows.EntireRow.Select
    Selection.Insert Shift:=xlDown
    Application.CutCopyMode = False

But it seems this wont work with tables. Anyone has an easy solution? I cant seem to figure it out

 

[VBE313]

Sub VBAnoob98()
Application.ScreenUpdating = False
With Sheets("Sheet1")
    If Not Intersect(ActiveCell, [Table1]) Is Nothing Then
       .ListObjects("Table1").ListRows.Add (ActiveCell.Row)
       .Range(ActiveCell, ActiveCell.End(xlToRight)).Copy
       .Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(1, 0).End(xlToRight)).PasteSpecial
       Application.CutCopyMode = False
    End If
End With
ActiveCell.Select
Application.ScreenUpdating = True
End Sub

 

[Vbanoob98]

Works very well, thank you

Heres another option I found where you can select more than 1 row

Sub DuplicateRows()

Dim ws As Worksheet
Dim mySel As Range
Dim mySelVis As Range
Dim rngArea As Range
Dim lRowSel As Long
Dim lRowNew As Long
Dim lRowsAdd As Long
Dim myList As ListObject
Dim myListRows As Long
Dim myListCols As Long
Dim c As Range

Dim lAreas As Long
Dim lRowsArea As Long

Set ws = ActiveSheet
Set mySel = Selection.EntireRow
lAreas = Selection.Areas.Count
lRowsArea = Selection.Areas(lAreas).Rows.Count
Set mySelVis = mySel.SpecialCells(xlCellTypeVisible)

lRowSel = mySel.Areas(lAreas).Cells(lRowsArea, 1).Row + 1

For Each rngArea In mySel.Areas
  For Each c In rngArea.Columns(1).Cells
    If Not Intersect(c, mySelVis) Is Nothing Then
      ws.Cells(lRowSel, 1).EntireRow.Insert
    End If
  Next c
Next rngArea

mySel.SpecialCells(xlCellTypeVisible).Copy
ws.Cells(lRowSel, 1).PasteSpecial Paste:=xlPasteAll

Application.CutCopyMode = False
End Sub