VBA to insert rows

mc136355

New Member
Joined
Mar 20, 2018
Messages
36
Hi ive searched google to try and find answer to my problem but there are similar questions but dont know how to manipulate the vba to suit me.

My problem is i need to achieve the following
i enter a value into A1 e.g 10 and it would then goto the start of my table data say A16 and then copy the row of data 10 times creating 10 identical rows of data. Any help on this would be appreciated.

thanks MC
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
Is your "table data" a Table or is it a range of data. If it's a table what is the table name.
 
Upvote 0
I am assuming that the row of data you want copied is Row 1 of your Table. If that is right, does this do what you want.

Code:
Sub InstTblRows()


    Dim tbl As ListObject
    Dim ct As Long, i As Long
    
    Set tbl = ActiveSheet.ListObjects("medicine")
    ct = ActiveSheet.Range("A1").Value
    With tbl
        For i = 1 To ct
            .ListRows.Add (1)
            .ListRows(2).Range.Copy
            .ListRows(1).Range.PasteSpecial xlPasteValues
        Next
    End With
    
End Sub
 
Upvote 0
Just realized that I named your table in my code as "medicine" and not "medline" as requested. Sorry about the confusion...
 
Upvote 0
Hi igold

Code works really well. The only problem is it seems to take a long time to add 5 rows and there is a lot of flickering. Obviously not the code. Would you have any suggestions thanks MC
 
Upvote 0
I glad it works for you. Add the two RED lines as shown below and that should take care of the flickering and pickup the pace a little...

Code:
Sub InstTblRows()


    Dim tbl As ListObject
    Dim ct As Long, i As Long
    
[COLOR=#ff0000]    Application.ScreenUpdating = False[/COLOR]
    Set tbl = ActiveSheet.ListObjects("medline")
    ct = ActiveSheet.Range("A1").Value
    With tbl
        For i = 1 To ct
            .ListRows.Add (1)
            .ListRows(2).Range.Copy
            .ListRows(1).Range.PasteSpecial xlPasteValues
        Next
    End With
[COLOR=#ff0000]    Application.ScreenUpdating = True[/COLOR]
    
End Sub
 
Upvote 0
This completely different method, while more lines of code, will be infinitely faster because all the work is being done in memory. The first code is slow because it is constantly going back and forth between the code and your worksheet. The downside is that as written it will not work if you have any formulas in your table. However, if your table does not contain any formulas, this will be much quicker. The other caveat is, that depending on the size of the table you may not be able to discern the difference in speed.

Please test on a backup copy of your data as this code will delete data that is not normally recoverable.

Code:
Sub InstTblRows()


    Dim tbl As ListObject
    Dim ct As Long, c As Long, trws As Long, r As Long
    Dim temtab1, temtab2
    Dim rng As Range
    
    Set tbl = ActiveSheet.ListObjects("medline")
    ct = ActiveSheet.Range("A1").Value + 1
    trws = tbl.ListRows.Count
    temtab1 = tbl.DataBodyRange
    ReDim temtab2(1 To ct + trws, 1 To tbl.ListColumns.Count)
    For r = 1 To ct
        For c = 1 To tbl.ListColumns.Count
            temtab2(r, c) = temtab1(1, c)
        Next
    Next
    For r = ct + 1 To UBound(temtab2, 1) - 1
        For c = 1 To tbl.ListColumns.Count
            temtab2(r, c) = temtab1(r - ct + 1, c)
        Next
    Next
    tbl.DataBodyRange.Delete
    Set rng = Range("medline[#All]").Resize(trws + ct, tbl.Range.Columns.Count)
    tbl.Resize rng
    tbl.DataBodyRange = temtab2
    
End Sub
 
Last edited:
Upvote 0
Hi igold

Thanks for the help. You are totally correct about formula not getting copied down. However with the new code you have supplied it runs and insert the lines i need but this one for some reason removes the formula from the original row and then copies the row x amount but without formula. Both codes run exactly as i need just the one issue with the formula. With not being as good with VB I dont see where the issue is (if there is one). Thanks for any help MC
 
Upvote 0
After playing around quite a bit, I am finding that the only way I can get this to work for you is with my original slower code with a minor change which I stupidly should have had there in the first place. Please try this code and see if it works for you.

This should deal with your formulas correctly...

Code:
Sub InstTblRows2()


    Dim tbl As ListObject
    Dim ct As Long, i As Long
    Application.ScreenUpdating = False
    Set tbl = ActiveSheet.ListObjects("medline")
    ct = ActiveSheet.Range("A1").Value
    With tbl
        For i = 1 To ct
            .ListRows.Add (1)
            .ListRows(2).Range.Copy
            .ListRows(1).Range.PasteSpecial xlPasteAll
        Next
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
End Sub

I hope this helps.
 
Upvote 0

Forum statistics

Threads
1,213,497
Messages
6,113,999
Members
448,543
Latest member
MartinLarkin

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