Macro double underline range if col q = *

Question

I have a question that I cant solve. The problem lies in col Q. What I want is simple:

Scan col Q from row 5 until last row (last row value is in cell "AL1") If there is a "*" (symbol is stored in cell "AK2") in that row of Q. Then double underline cells A thru AF in that row, continue scanning down until last row.

    Sub Reformat()

    Dim SrchRng3 As Range
    Dim c3 As Range, f As String

   Set SrchRng3 = ActiveSheet.Range("Q5",          ActiveSheet.Range("Q100000").End(xlUp))
Set c3 = SrchRng3.Find(Range("ak2"), LookIn:=xlValues)
If Not c3 Is Nothing Then
    f = c3.Address
    Do
        With ActiveSheet.Range("A" & c3.Row & ":AF" & c3.Row)
        Range("A" & c3.Row & ":AF" & c3.Row).Select
                .Borders (xlEdgeBottom)
                .LineStyle = xlDouble
                .ThemeColor = 4
                .TintAndShade = 0.399945066682943
                .Weight = xlThick
        End With
        Set c3 = SrchRng3.FindNext(c3)
    Loop While c3.Address <> f
End If
End Sub

Answer 1

The AutoFilter version:

Option Explicit

Public Sub showSymbol()
    Dim lRow As Long, ur As Range, fr As Range

    Application.ScreenUpdating = False
    With ActiveSheet
        lRow = .Range("Q" & .Rows.Count).End(xlUp).Row
        Set ur = .Range("A5:AF" & lRow)
        Set fr = ur.Offset(1).Resize(ur.Rows.Count - 1)

        ur.Columns(17).AutoFilter Field:=1, Criteria1:="~" & .Range("AK2").Value2
        fr.Borders(xlEdgeBottom).LineStyle = xlDouble
        fr.Borders(xlInsideHorizontal).LineStyle = xlDouble
        ur.AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

---

To execute it for every OnCahange event of one particular sheet add this to its VBA module:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    With Target
        If .CountLarge = 1 Then 'run only if one cell was updated

            'restrict the call to column Q only, and if the new value is same as cell AK2
            If .Column = 17 And .Value2 = Me.Range("AK2").Value2 Then showSymbol

        End If
    End With
End Sub

---

To execute it for all sheets in the file, add this to the VBA module for ThisWorkbook:

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    If Target.CountLarge = 1 Then If Target.Column = 17 Then showSymbol

End Sub

Answer 2

Is this what you are trying? I have commented the code so you shouldn't have a problem understanding it. If you still do or you get an error, simply let me know :)

Sub Reformat()
    Dim rng As Range
    Dim aCell As Range, bCell As Range
    Dim ws As Worksheet
    Dim lRow As Long

    '~~> Change as applicable. Do not use Activesheet.
    '~~> The Activesheet may not be the sheet you think
    '~~> is active when the macro runs
    Set ws = ThisWorkbook.Sheets("Sheet1")

    With ws
        '~~> Find last row in Col Q
        lRow = .Range("Q" & .Rows.Count).End(xlUp).Row

        '~~> Set your Find Range
        Set rng = .Range("Q5:Q" & lRow)

        '~~> Find (When searching for "*" after add "~" before it.
        Set aCell = rng.Find(What:="~" & .Range("AK2"), LookIn:=xlFormulas, _
                    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False)

        If Not aCell Is Nothing Then
            Set bCell = aCell

            '~~> Create the necessary border that you are creating
            With .Range("A" & aCell.Row & ":AF" & aCell.Row).Borders(xlEdgeBottom)
                .LineStyle = xlDouble
                .ThemeColor = 4
                .TintAndShade = 0.399945066682943
                .Weight = xlThick
            End With

            Do
                Set aCell = rng.FindNext(After:=aCell)

                If Not aCell Is Nothing Then
                    If aCell.Address = bCell.Address Then Exit Do

                    '~~> Create the necessary border that you are creating
                    With .Range("A" & aCell.Row & ":AF" & aCell.Row).Borders(xlEdgeBottom)
                        .LineStyle = xlDouble
                        .ThemeColor = 4
                        .TintAndShade = 0.399945066682943
                        .Weight = xlThick
                    End With
                Else
                   Exit Do
                End If
            Loop
        End If
    End With
End Sub

Screenshot