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

[goldman65]

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:

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

 

[steve the fish]

Something like this?

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]

Something like this?

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:

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]

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]

Add these two lines after the 'loop':

    Set rng = Nothing
    Set FirstRange = Nothing

 

[steve the fish]

See if this does the same thing:

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]

Add these two lines after the 'loop':

    Set rng = Nothing
    Set FirstRange = Nothing

Great names achieve great things....hence the reason your name is Steve....LOL. thanks buddy, it worked a treat.

Regards,

Steve

 

[goldman65]

See if this does the same thing:

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