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

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
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
 
Upvote 0
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
 
Upvote 0
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?
 
Upvote 0
Add these two lines after the 'loop':

Code:
    Set rng = Nothing
    Set FirstRange = Nothing
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,557
Messages
6,114,288
Members
448,563
Latest member
MushtaqAli

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