Insert cells below and copy above data

[Nadine67]

Hello and thank you for any attention my post may receive.

My goal is to:

1. find every occurrence of the word "Weekly" in column C e.g. C3,C6;
2. insert 6 lines below (in range A2:C500) each occurrence;
3. fill each occurrence of those 6 blank lines with the data from range A2:C500 where the word "Weekly" was found.

[TABLE="class: grid, width: 20"]
<tbody>[TR]
[TD][/TD]
[TD]A
[/TD]
[TD]B
[/TD]
[TD]C
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]area
[/TD]
[TD]type
[/TD]
[TD]frequency
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]264a
[/TD]
[TD]a
[/TD]
[TD]daily
[/TD]
[/TR]
[TR]
[TD]3
[/TD]
[TD]260d
[/TD]
[TD]a
[/TD]
[TD]weekly
[/TD]
[/TR]
[TR]
[TD]4
[/TD]
[TD]264a
[/TD]
[TD]c
[/TD]
[TD]monthy
[/TD]
[/TR]
[TR]
[TD]5
[/TD]
[TD]273c
[/TD]
[TD]e
[/TD]
[TD]daily
[/TD]
[/TR]
[TR]
[TD]6
[/TD]
[TD]264b
[/TD]
[TD]c
[/TD]
[TD]weekly
[/TD]
[/TR]
[TR]
[TD]7
[/TD]
[TD]273a
[/TD]
[TD]b
[/TD]
[TD]daily
[/TD]
[/TR]
[TR]
[TD]8
[/TD]
[TD]264a
[/TD]
[TD]d
[/TD]
[TD]daily
[/TD]
[/TR]
</tbody>[/TABLE]


The code I currently have finds the first occurrence, inserts 6 full rows above, then fills those six rows with the data that was above the occurrence. It is rather back to front and I am at lost as to where to make further changes to achieve my goal.

Sub InsertRows()

Cells.Find(What:="Weekly", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate

Dim d As Integer
d = Range("C:C").End(xlDown).Row
Dim c As Range
    For i = d To 1 Step -1
        If Cells(i, 3).Value = "Weekly"Then
            Dim Rng, n As Long, k As Long
            Application.ScreenUpdating = False
            Rng = 6
                If Rng = "" Then Exit Sub
                Range(ActiveCell, ActiveCell.Offset(Val(Rng) - 1, 0)).EntireRow.insert 'Shift:=xlDown
                k = ActiveCell.Offset(-1, 0).Row
                n = Cells(k, 4).End(xlToLeft).Column
                Range(Cells(k, 1), Cells(k + Val(Rng), n)).FillDown
            End If
    Next
End Sub

Thanks again in advance, and have a great day!

 

[Nadine67]

Thank to those who viewed my post.

I am still looking for a solution, however on the positive side I have made a change that inserts the rows below and populates them with the correct data...but only when "Weekly" appears once in the column.

When "Weekly" appears 2X in the column the code below inserts 18 rows below the first occurrence of "Weekly", 3X in the column the code below inserts 30 rows below the first occurrence of "Weekly", 4X in the column the code below inserts 36 rows below the first occurrence of "Weekly"...

I am rather perplexed...

Sub InsertRows()

Cells.Find(What:="Weekly", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Dim d As Integer
d = Range("C:C").End(xlDown).Row
Dim c As Range
    For i = d To 1 Step -1
        If Cells(i, 3).Value = "Weekly" Then
            Dim Rng, n As Long, k As Long
            Application.ScreenUpdating = False
            Rng = 6
                If Rng = "" Then Exit Sub
                    Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(Val(Rng), 0)).EntireRow.insert
                    k = ActiveCell.Row '.Offset(-1, 0)
                    n = Cells(k, 4).End(xlToLeft).Column
                    Range(Cells(k, 1), Cells(k + Val(Rng), n)).FillDown
            End If
    Next
End Sub

Again, any help would be greatly appreciated.

 

[Fluff]

If you'll never have 2 or Weekly together, try

Sub insertRws()
   Dim Rng As Range
   With Range("C:C")
      .Replace "Weekly", "=XXXWeekly", xlWhole, , False, , False, False
      For Each Rng In .SpecialCells(xlFormulas, xlErrors).Areas
         Rng.Offset(1).Resize(6).EntireRow.Insert
         Rng.Offset(, -2).Resize(7).EntireRow.FillDown
      Next Rng
      .Replace "=XXXWeekly", "Weekly", xlWhole, , False, , False, False
   End With
End Sub

 

[Nadine67]

Thank you Fluff.

Yes there will definitely be occasions where multiple occurrences of "Weekly" are together.

I do appreciate your help with this. I will keep trying for a solution.

 

[Fluff]

In that case try

Sub insertRws()
   Dim Rng As Range
   Dim i As Long
   With Range("C:C")
      .Replace "Weekly", "=XXXWeekly", xlWhole, , False, , False, False
      For Each Rng In .SpecialCells(xlFormulas, xlErrors).Areas
         If Rng.Count = 1 Then
            Rng.Offset(1).Resize(6).EntireRow.Insert
            Rng.Offset(, -2).Resize(7).EntireRow.FillDown
         Else
            For i = Rng.Count To 1 Step -1
               Rng(i).Offset(1).Resize(6).EntireRow.Insert
               Rng(i).Offset(, -2).Resize(7).EntireRow.FillDown
            Next i
         End If
      Next Rng
      .Replace "=XXXWeekly", "Weekly", xlWhole, , False, , False, False
   End With
End Sub

 

[Nadine67]

*** SOLVED ***

Wow, you have solved my issue!

Your code achieves my goal.

Thank you for your help and your time Fluff. You have made my day.

 

[Fluff]

Glad to help & thanks for the feedback