Copy row and insert bellow itself on a table-CodePudding

I'm trying to work on a code to do the following: In my table of the current active worksheet I would like to copy the entire line of the current cell (if possible respecting the limit of the columns of the table A$:K$) to copy just below duplicating the information, currently I have a code that inserts the number of lines for me automatically just below the current cell, but I would like to know if it is possible to increment this code making it insert these lines already with the same content of the current line of the cell where I yeah, i tried some codes but i didnt get anywhere, they all just inserted the lines and some gave error that the paste space was small, so i won't even put them here.

My code to insert lines, without breaking the table or anything ( currently working fine ) :

Sub INSERIR_LINHAS()

Application.ScreenUpdating = False

    Dim Table As Object
    Dim Rows As Range
    Set Rows = Worksheets("CC").Range("B18") 'Number of rows to be inserted
    Dim rng As Range
    Set rng = ActiveCell
    
If Rows = ("1") Then GoTo ErrHandler


Set Table = ActiveSheet.ListObjects(1)
With Table
    If Not Intersect(Selection, .DataBodyRange) Is Nothing Then
        rng.EntireRow.Offset(1).Resize(Rows.Value - 1).Insert Shift:=xlDown 'Rows must be: Rows-1 because of the row in current cell location
    End If
End With

Exit Sub

ErrHandler:
    Exit Sub

Application.ScreenUpdating = True


End Sub

Demonstration of the intended result:

First, the line in this case that I want to copy would be the one marked in red Table Header (A3:AK)

Next, let's say my code has the information that it needs to duplicate that line 5 more times (it has the information that it needs 6 lines in total).And this would be the result I want.

With @Darren Bartrup-Cook code I got the result I wanted, just a few tweaks for the code to work on the active Sheet and Table:

Sub Test()

    Dim MyTable As Object
    Dim RowsToAdd As Long
    RowsToAdd = Worksheets("CC").Range("B18") 
        
    Set MyTable = ActiveSheet.ListObjects(1)
    
    If RowsToAdd > 0 Then
            If Not Intersect(Selection, MyTable.DataBodyRange) Is Nothing Then
            
            Dim SelectedRow As Long
            SelectedRow = Intersect(Selection, MyTable.DataBodyRange).Row - MyTable.HeaderRowRange.Row
            
            Dim RowCounter As Long
            For RowCounter = SelectedRow To SelectedRow   RowsToAdd - 1
                MyTable.ListRows.Add Position:=RowCounter   1
                MyTable.ListRows(RowCounter).Range.Copy Destination:=MyTable.ListRows(RowCounter   1).Range
            Next RowCounter
        End If
    End If

End Sub

CodePudding user response：

Something like this should work:

Sub Test()

    'Get the table by name and location.
    'Not relying on the correct sheet being active, and the first table being the one you need.
    Dim MyTable As ListObject
    Set MyTable = ThisWorkbook.Worksheets("Sheet1").ListObjects("Table1")
    
    Dim RowsToAdd As Long
    RowsToAdd = ThisWorkbook.Worksheets("Sheet1").Range("E1")

    If RowsToAdd > 0 Then
        If Not Intersect(Selection, MyTable.DataBodyRange) Is Nothing Then
            
            'Calculate which row in the table is selected.
            Dim SelectedRow As Long
            SelectedRow = Intersect(Selection, MyTable.DataBodyRange).Row - MyTable.HeaderRowRange.Row
            
            Dim RowCounter As Long
            For RowCounter = SelectedRow To SelectedRow   RowsToAdd - 1
                MyTable.ListRows.Add Position:=RowCounter   1
                MyTable.ListRows(RowCounter).Range.Copy Destination:=MyTable.ListRows(RowCounter   1).Range
            Next RowCounter
        End If
    End If

End Sub