1. Insert Empty Rows in worksheet A. Copy Range from worksheet B. Paste Range to Each Empty Rows until end of worksheet A

Hi, I am looking to paste a range by VBA to a massive document sparing me valuable time.

1. Insert Empty Row(s) before each Name change in Column D of worksheet A.
2. Copy Named Range ("A2:V13") from worksheet B.
3. Paste Named Range to Each Empty Row(s) starting at Column A until end of worksheet A.

Worksheet A is usually 65000 lines long by 22 columns large with a minimum of 250+ Name changes.

-----------------------------------------------
I have used the following subs:

Insert Empty Lines (works fine - might no be best):

Option Compare Text
Sub addRows()
    Dim Rw     As Long
    Dim LastRw As Long
    LastRw = ActiveSheet.UsedRange.Rows.Count
   ' loop through column D
    For Rw = LastRw To 2 Step -1
    'ignore empty cells
        If Not IsEmpty(Cells(Rw - 1, 1)) Then
        'if the cells don't match add a row
            If Cells(Rw, 1).Value <> Cells(Rw - 1, 1).Value Then
                Cells(Rw, 1).EntireRow.Insert Shift:=xlDown
                Cells(Rw, 1).EntireRow.Insert Shift:=xlDown
                Cells(Rw, 1).EntireRow.Insert Shift:=xlDown
                Cells(Rw, 1).EntireRow.Insert Shift:=xlDown
                Cells(Rw, 1).EntireRow.Insert Shift:=xlDown
                Cells(Rw, 1).EntireRow.Insert Shift:=xlDown
                Cells(Rw, 1).EntireRow.Insert Shift:=xlDown
                Cells(Rw, 1).EntireRow.Insert Shift:=xlDown
                Cells(Rw, 1).EntireRow.Insert Shift:=xlDown
                Cells(Rw, 1).EntireRow.Insert Shift:=xlDown
                Cells(Rw, 1).EntireRow.Insert Shift:=xlDown
                Cells(Rw, 1).EntireRow.Insert Shift:=xlDown
            End If
        End If
    Next Rw
End Sub

------------------------------------------
Copy Range Paste to worksheet A (copy+paste OK but not to each empty rows):
Sub PasteRange()
Sheets("YellowCells").Range("A3:V14").Copy
Do
Sheets("MacroTest").Range("A" & Sheets("MacroTest").Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteFormats)
Sheets("MacroTest").Range("A" & Sheets("MacroTest").Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteFormulas)
Loop
End Sub
--------------------------------------------

Thanks in advance for the time you take to review this.

 
fredericgilbertAsked:
Who is Participating?
 
NorieConnect With a Mentor VBA ExpertCommented:
Try this.
Option Explicit

Sub InsertNamedRange()
Dim wsA As Worksheet
Dim wsB As Worksheet
Dim rngdst As Range
Dim rngSrc As Range

Set wsA = Worksheets("A")
Set wsB = Worksheets("B")
    Set rngdst = wsA.Range("d2")
    Set rngSrc = wsB.Range("NamedRange")
    
    While rngdst.Value <> ""
           If rngdst.Value <> rngdst.Offset(1) Then
                rngdst.Offset(1).Resize(rngSrc.Rows.Count).EntireRow.Insert
                
                rngSrc.Copy rngdst.Offset(1, -3)
                Set rngdst = rngdst.Offset(rngSrc.Rows.Count)
            End If
            
        Set rngdst = rngdst.Offset(1)
    Wend
End Sub

Open in new window

0
 
StephenJRCommented:
Do you mean that, e.g., if row 5 is different from row 6 then you want to insert your range A2:V13 between them? Also, your code is comparing column A but you refer to column D in your question.
0
 
StephenJRCommented:
If you could post a small workbook that would probably clear it all up.
0
Get your problem seen by more experts

Be seen. Boost your question’s priority for more expert views and faster solutions

 
fredericgilbertAuthor Commented:
Hi StephenJR,

Yes, if row 5 is different from row 6 then you want to insert your range A2:V13 between them.
The Name change occurs in Column D while the empty (inserted) rows the sub is checking are in column A.

Here is a workbook (much smaller than the regular).
 20110914-ExpertsExchange-workdoc.xlsm
0
 
StephenJRCommented:
Does this work?
Sub addRows()
    Dim Rw     As Long
    Dim LastRw As Long
    
    LastRw = Range("D" & Rows.Count).End(xlUp).Row
   ' loop through column D
    For Rw = LastRw + 1 To 3 Step -1
    'ignore empty cells
        If Not IsEmpty(Cells(Rw - 1, 4)) Then
        'if the cells don't match add a row
            If Cells(Rw, 4).Value <> Cells(Rw - 1, 4).Value Then
                Cells(Rw, 1).EntireRow.Resize(12).Insert Shift:=xlDown
                Sheets("YellowCells").Range("A2:V13").Copy
                Cells(Rw, 1).PasteSpecial xlPasteFormulas
                Cells(Rw, 1).PasteSpecial xlPasteFormats
            End If
        End If
    Next Rw
End Sub

Open in new window

0
 
NorieVBA ExpertCommented:
Stephen

Why are you looping backwards?

It isn't really necessary unless you are deleting.

You just need to keep a close eye on your offsets, no of rows etc.
0
 
StephenJRCommented:
imnorie: suppose I was being lazy and tweaking the OP's code!

fredericgilbert: don't mention it.
0
 
NorieVBA ExpertCommented:
Stephen

Sorry to have asked, but I've always wondered.

I suppose looping backwards is easier
0
 
StephenJRCommented:
imnorie - nothing to apologise for. If I were starting from scratch I would not necessarily have done it that way. And your method is no doubt more efficient.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.