VBA to insert rows

[mc136355]

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

 

[igold]

Is your "table data" a Table or is it a range of data. If it's a table what is the table name.

 

[mc136355]

Table is called medline thanks MC

 

[igold]

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.

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

 

[igold]

Just realized that I named your table in my code as "medicine" and not "medline" as requested. Sorry about the confusion...

 

[mc136355]

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

 

[igold]

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

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

 

[igold]

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.

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

 

[mc136355]

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

 

[igold]

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

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.