VBA: Find all instances of exact cell contents, and format

[2vbr]

I've tried using Excel's Record Macro featrure to do this, but it doesn't seem to want to record the "Find" part.

I need to highlight columns B:D, find all instances of a word (in this case, "new"), and then perform the following:

1. Remove all borders
2. Add Bottom border.

Basically changing this:

I have a rather long VBA macro I use to format everything else, but this step is missing, and I was hoping I could sneakily slip a script in that would perform this last step.

 

[Michael M]

How about

Sub MM1()
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
    Range("B1:D" & lr).Borders.LineStyle = xlNone
For r = lr To 1 Step -1
    If Cells(r, 2).Value = "" Then
        Range(Cells(r, 2), Cells(r, 4)).Borders(xlEdgeBottom).LineStyle = xlNone
     Else:
     Range(Cells(r, 2), Cells(r, 4)).Borders(xlEdgeBottom).LineStyle = xlContinuous
     End If
Next r
End Sub

 

[2vbr]

Ah. My bad. I messed up.

Your macro works exactly as requested (thankyou!), unfortunately I described what I wanted wrong.

Your macro finds all instances of New and changes the borders, however some of my data does not have New cell at the top. But the macro changes the borders of whatever the top cell is, wether it says "New" or not.


Here's what I actually needed:

So sorry about the mixup. I didn't describe it well. I hope I did it right this time.

 

[Michael M]

I am completely confused now....which isn't hard to do !!
There doesn't seem to be a correlation regarding what is border and what isn't..."One seems to have a top and bottom border on 2 occasions, but not on a 3rd ??

 

[2vbr]

I made a video recording:

What I need to do:
MP4 Video
Video (mirror)

What the macro is doing right now:
MP4 Video
Video (mirror)

 

[Trebor76]

Hi 2vbr,

Welcome to MrExcel!!

See how this goes:

Option Explicit
Sub Macro1()

    'https://www.mrexcel.com/board/threads/vba-find-all-instances-of-exact-cell-contents-and-format.1146877

    Dim rngMyRange As Range
    Dim rngCellFound As Range
    Dim strFirstAddress As String
    Dim strCurrentAddress As String
   
    Application.ScreenUpdating = False
   
    Set rngMyRange = ActiveWorkbook.Worksheets("Sheet3").Range("B:D") 'Works on Sheet3 for columns A to D. Change to suit.
   
    Set rngCellFound = rngMyRange.Find("New")
    strFirstAddress = rngCellFound.Address
    Do While Not strFirstAddress = strCurrentAddress
        With rngCellFound
            .Borders.LineStyle = xlLineStyleNone
            .Borders(xlEdgeBottom).Weight = xlThin
            'Strangely adding a bottom border sometimes also added a left and/or right border
            .Borders(Excel.XlBordersIndex.xlEdgeLeft).LineStyle = xlLineStyleNone
            .Borders(Excel.XlBordersIndex.xlEdgeRight).LineStyle = xlLineStyleNone
        End With
        Set rngCellFound = rngMyRange.FindNext(rngCellFound)
        strCurrentAddress = rngCellFound.Address
    Loop
   
    Application.ScreenUpdating = True
   
    Beep 'Alert the user the code has finished

End Sub

Regards,

Robert

 

[2vbr]

Works great!

VERY much appreciated!

 

[2vbr]

If I may ask; is it possible to use the same macro to do this with other words at the same time, in additon to "New"?

I thought I'd try:

Set rngCellFound = rngMyRange.Find("New", "Newer")

But apparently that was a bad guess.

 

[Trebor76]

Thanks for letting us know and you’re welcome ?
Thanks too for the time Michael spent ?

 

[Trebor76]

is it possible to use the same macro to do this with other words at the same time, in additon to "New"?

Try this:

Option Explicit
Sub Macro2()

    'https://www.mrexcel.com/board/threads/vba-find-all-instances-of-exact-cell-contents-and-format.1146877

    Dim rngMyRange As Range
    Dim rngCellFound As Range
    Dim strFirstAddress As String
    Dim strCurrentAddress As String
    Dim varMyArray As Variant
   
    Application.ScreenUpdating = False
   
    varMyArray = Array("New", "Newest") 'Word(s) for the code to modify its cell borders
   
    Set rngMyRange = ActiveWorkbook.Worksheets("Sheet3").Range("B:D") 'Works on Sheet3 for columns A to D. Change to suit.
   
    Set rngCellFound = rngMyRange.Find(varMyArray)
    strFirstAddress = rngCellFound.Address
    Do While Not strFirstAddress = strCurrentAddress
        With rngCellFound
            .Borders.LineStyle = xlLineStyleNone
            .Borders(xlEdgeBottom).Weight = xlThin
            'Strangely adding a bottom border sometimes also left and right border
            .Borders(Excel.XlBordersIndex.xlEdgeLeft).LineStyle = xlLineStyleNone
            .Borders(Excel.XlBordersIndex.xlEdgeRight).LineStyle = xlLineStyleNone
        End With
        Set rngCellFound = rngMyRange.FindNext(rngCellFound)
        strCurrentAddress = rngCellFound.Address
    Loop
   
    Application.ScreenUpdating = True
   
    Beep 'Alert the user the code has finished

End Sub

[/QUOTE]