VBA code with Formula that applies a Conditional Formatting border to a range of cells

[Uhrlaff]

I'm creating a process for a group of users and want to make it user-friendly, and I already have an existing Macro which performs about 35 steps. I want to add one last step that applies a thin-line bottom border to certain cells in a range, and based upon a formula.
The conditional formatting can be applied/stored in any cell in row 2 such as A2, B2, D2, etc. and the formula is as follows: =COUNTIF($A1, "*Match*")
and the range in which to apply the bottom border is: =$A$2:$BG$5000

I believe the below code is a pretty good start, but I need help defining it correctly. Thank you so much.

Sub VBA_borders()
Dim iRange as Range
Dim iCells as Range
Set iRange = ThisWorkbook.ActiveSheet.UsedRange

For each iCells in iRange
If Not isEmpty(iCells) Then
Borders:=x1EdgeBottom, _
LineStyle:=x1Continuous, _
Weight:=x1Thin, _
ColorIndex:=x1Automatic

thanks,
David

 

[Uhrlaff]

I'm replying to my own original question, and I'm just uploading an image of what I'm looking for.

 

[Peter_SSs]

I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

Test this with a copy of your workbook.

Sub Add_Underlines()
  Dim rFound As Range
  Dim FirstAddr As String
  
  Set rFound = Columns("A").Find(What:="Match", LookAt:=xlPart, MatchCase:=False)
  If Not rFound Is Nothing Then
    Application.ScreenUpdating = False
    FirstAddr = rFound.Address
    Do
      rFound.Offset(1).Resize(, 4).Borders(xlEdgeBottom).LineStyle = xlContinuous
      Set rFound = Columns("A").Find(What:="Match", After:=rFound, LookAt:=xlPart, MatchCase:=False)
    Loop Until rFound.Address = FirstAddr
    Application.ScreenUpdating = True
  End If
End Sub

 

[Uhrlaff]

Thank you Peter.
I will test your code on Monday. I'm in New York time zone. Take care!
David

 

[Uhrlaff]

I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

Test this with a copy of your workbook.

Sub Add_Underlines()
  Dim rFound As Range
  Dim FirstAddr As String
 
  Set rFound = Columns("A").Find(What:="Match", LookAt:=xlPart, MatchCase:=False)
  If Not rFound Is Nothing Then
    Application.ScreenUpdating = False
    FirstAddr = rFound.Address
    Do
      rFound.Offset(1).Resize(, 4).Borders(xlEdgeBottom).LineStyle = xlContinuous
      Set rFound = Columns("A").Find(What:="Match", After:=rFound, LookAt:=xlPart, MatchCase:=False)
    Loop Until rFound.Address = FirstAddr
    Application.ScreenUpdating = True
  End If
End Sub

Peter, this code worked perfectly for me, so thank you so much. One additional thing I would like to do is add a red-colored line border for the case for a different word, namely "Missing".
I tried to set the line color and even had trouble with this.
David

 

[Peter_SSs]

Firstly, what about the first point in my previous post?

Secondly, could we again have some sample data and results so we can see what sort of things we could expect in the sheet & exactly where the red line(s) should be?

 

[Uhrlaff]

Firstly, what about the first point in my previous post?

Secondly, could we again have some sample data and results so we can see what sort of things we could expect in the sheet & exactly where the red line(s) should be?

I have updated my account details. And I have attached a screenshot for sample data regarding the red line. Thanks so much

 

[Peter_SSs]

I have updated my account details.

Thanks for that.


.. and for the sample.
I'm not sure if you wanted an exact match for "Missing". The code below still looks for a partial match so it would underline "There was a missing part". If you don't want that then try changing LookAt:=xlPart to LookAt:=xlWhole in the bottom section of thee code (in two places).

Sub Add_Underlines_v2()
  Dim rFound As Range
  Dim FirstAddr As String
  
  Set rFound = Columns("A").Find(What:="Match", LookAt:=xlPart, MatchCase:=False)
  If Not rFound Is Nothing Then
    Application.ScreenUpdating = False
    FirstAddr = rFound.Address
    Do
      rFound.Offset(1).Resize(, 4).Borders(xlEdgeBottom).LineStyle = xlContinuous
      Set rFound = Columns("A").Find(What:="Match", After:=rFound, LookAt:=xlPart, MatchCase:=False)
    Loop Until rFound.Address = FirstAddr
    Application.ScreenUpdating = True
  End If
  
  Set rFound = Columns("A").Find(What:="Missing", LookAt:=xlPart, MatchCase:=False)
  If Not rFound Is Nothing Then
    Application.ScreenUpdating = False
    FirstAddr = rFound.Address
    Do
      With rFound.Resize(, 4).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Color = vbRed
      End With
      Set rFound = Columns("A").Find(What:="Missing", After:=rFound, LookAt:=xlPart, MatchCase:=False)
    Loop Until rFound.Address = FirstAddr
    Application.ScreenUpdating = True
  End If
End Sub

 

[Uhrlaff]

Thanks for that.


.. and for the sample.
I'm not sure if you wanted an exact match for "Missing". The code below still looks for a partial match so it would underline "There was a missing part". If you don't want that then try changing LookAt:=xlPart to LookAt:=xlWhole in the bottom section of thee code (in two places).

Sub Add_Underlines_v2()
  Dim rFound As Range
  Dim FirstAddr As String
 
  Set rFound = Columns("A").Find(What:="Match", LookAt:=xlPart, MatchCase:=False)
  If Not rFound Is Nothing Then
    Application.ScreenUpdating = False
    FirstAddr = rFound.Address
    Do
      rFound.Offset(1).Resize(, 4).Borders(xlEdgeBottom).LineStyle = xlContinuous
      Set rFound = Columns("A").Find(What:="Match", After:=rFound, LookAt:=xlPart, MatchCase:=False)
    Loop Until rFound.Address = FirstAddr
    Application.ScreenUpdating = True
  End If
 
  Set rFound = Columns("A").Find(What:="Missing", LookAt:=xlPart, MatchCase:=False)
  If Not rFound Is Nothing Then
    Application.ScreenUpdating = False
    FirstAddr = rFound.Address
    Do
      With rFound.Resize(, 4).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Color = vbRed
      End With
      Set rFound = Columns("A").Find(What:="Missing", After:=rFound, LookAt:=xlPart, MatchCase:=False)
    Loop Until rFound.Address = FirstAddr
    Application.ScreenUpdating = True
  End If
End Sub

This helps me so much. Thank you for your keen insight. I have no further questions at this time.

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.