Insert a Blank Row above the First Instance of Several Keywords and Paste Values

goldman65

New Member
Joined
Dec 2, 2016
Messages
10
Hi guys,

I have a supermarket shopping list which works really well, except I have duplicated a macro six times which I call from the master macro because I don't know how to combine them all into one macro.

In column B I have six named categories (for brevity, I'll call them "Run", "Yes", "No", "Maybe", "Ok", "Righto"). Each category can appear up to 50 times in column B. What I want to do is find the first instance of one of these categories and do the following:

  1. Insert a blank row above
  2. Bold enable the first instance of the category
  3. Copy this first instance of the category
  4. Paste into Column C into the newly created blank row

This macro does everything I want, but I'm trying to avoid calling it five other times. Any suggestions would be greatly appreciated:

Code:
Sub InsertRepeat2()    Dim rng As Range
    rng = Sheet11.Range("T5:T10")
    Dim FirstRange As Excel.Range
    
    Sheet9.Unprotect Password:="yes"


    Set rng = Sheet11.Range("B:B").Find(What:="Yes", MatchCase:=False, Lookat:=xlWhole)
    Do While Not rng Is Nothing
        If FirstRange Is Nothing Then
            Set FirstRange = rng
        Else
            If rng.Address = FirstRange.Address Then
                Exit Do
            End If
        End If
         
        If WorksheetFunction.CountBlank(rng.Offset(0).EntireRow) <> Columns.Count Then
            
            rng.Offset(0).EntireRow.Insert
            rng.Font.Bold = True
            
        rng.Copy
        rng.Offset(-1, 1).PasteSpecial Paste:=xlPasteValues
        rng.Offset(-1, 1).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
        End If
         
    Loop
    Sheet9.Protect Password:="yes"
End Sub

Thanks guys,
Steve
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest

steve the fish

Well-known Member
Joined
Oct 20, 2009
Messages
8,423
Office Version
  1. 365
Platform
  1. Windows
Something like this?

Code:
arr = Array("Run", "Yes", "No", "Maybe", "Ok", "Righto")
For i = LBound(arr) To UBound(arr)
    myFind = arr(i)
    'add your macro here using myFind in .Find
Next
 

goldman65

New Member
Joined
Dec 2, 2016
Messages
10
Something like this?

Code:
arr = Array("Run", "Yes", "No", "Maybe", "Ok", "Righto")
For i = LBound(arr) To UBound(arr)
    myFind = arr(i)
    'add your macro here using myFind in .Find
Next

Hi Steve,

It's Steve here, I'm not sure if there is an echo or I have a stutter...LOL.... anyway, I've added your code, but unfortunately, the only category that copied across was "Pantry & Dry Goods. Here is my revised code:

Code:
Sub InsertRepeat2()    Dim rng As Range
    Dim FirstRange As Excel.Range
    
    Sheet9.Unprotect Password:="yes"


    arr = Array("Fruit & Vegetables", "Pantry & Dry Goods", "Meat, Poultry & Seafood", "Chilled & Frozen Goods", _
    "Cleaning, Pets & Misc", "Personal & Pharmaceutical")
For i = LBound(arr) To UBound(arr)
    myFind = arr(i)
    'add your macro here using myFind in .Find
    Set rng = Sheet11.Range("B:B").Find(What:="Pantry & Dry Goods", MatchCase:=False, Lookat:=xlWhole)
    Do While Not rng Is Nothing
        If FirstRange Is Nothing Then
            Set FirstRange = rng
        Else
            If rng.Address = FirstRange.Address Then
                Exit Do
            End If
        End If
         
        If WorksheetFunction.CountBlank(rng.Offset(0).EntireRow) <> Columns.Count Then
            
            rng.Offset(0).EntireRow.Insert
            rng.Font.Bold = True
            
        rng.Copy
        rng.Offset(-1, 1).PasteSpecial Paste:=xlPasteValues
        rng.Offset(-1, 1).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
        End If
         
    Loop
    Sheet9.Protect Password:="yes"
Next


End Sub
 

goldman65

New Member
Joined
Dec 2, 2016
Messages
10
Hi Steve,

I re-read your suggestion and edited the following line: "Set rng = Sheet11.Range("B:B").Find(What:=myFind, MatchCase:=False, Lookat:=xlWhole)". Unfortunately, the workbook wouldn't stop looping and eventually crashed. Any other suggestions would be greatly appreciated?
 

steve the fish

Well-known Member
Joined
Oct 20, 2009
Messages
8,423
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Add these two lines after the 'loop':

Code:
    Set rng = Nothing
    Set FirstRange = Nothing
 

steve the fish

Well-known Member
Joined
Oct 20, 2009
Messages
8,423
Office Version
  1. 365
Platform
  1. Windows
See if this does the same thing:

Code:
Dim rng As Range
arr = Array("Fruit & Vegetables", "Pantry & Dry Goods", "Meat, Poultry & Seafood", "Chilled & Frozen Goods", _
    "Cleaning, Pets & Misc", "Personal & Pharmaceutical")
    
For i = LBound(arr) To UBound(arr)
    myFind = arr(i)
    Set rng = Sheet11.Range("B:B").Find(What:=myFind, After:=Sheet11.Range("B" & Rows.Count), MatchCase:=False, Lookat:=xlWhole)
    If Not rng Is Nothing Then
        With rng
            .EntireRow.Insert
            .Font.Bold = True
            .Offset(-1, 1) = .Value
            .Offset(-1, 1).Font.Bold = True
            Set rng = Nothing
        End With
    End If
Next
 

goldman65

New Member
Joined
Dec 2, 2016
Messages
10
See if this does the same thing:

Code:
Dim rng As Range
arr = Array("Fruit & Vegetables", "Pantry & Dry Goods", "Meat, Poultry & Seafood", "Chilled & Frozen Goods", _
    "Cleaning, Pets & Misc", "Personal & Pharmaceutical")
    
For i = LBound(arr) To UBound(arr)
    myFind = arr(i)
    Set rng = Sheet11.Range("B:B").Find(What:=myFind, After:=Sheet11.Range("B" & Rows.Count), MatchCase:=False, Lookat:=xlWhole)
    If Not rng Is Nothing Then
        With rng
            .EntireRow.Insert
            .Font.Bold = True
            .Offset(-1, 1) = .Value
            .Offset(-1, 1).Font.Bold = True
            Set rng = Nothing
        End With
    End If
Next

The beauty about this code, Steve is that it avoids the dreaded loop. Very good
 

Watch MrExcel Video

Forum statistics

Threads
1,133,538
Messages
5,659,384
Members
418,500
Latest member
Guru Prasad S

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
Top