Макро диапазон двойного подчеркивания, если col q = *

Question

У меня есть вопрос, который я не могу решить. Проблема заключается в пол Q. Что я хочу, это просто:

Просканируйте столбец Q от строки 5 до последней строки (значение последней строки находится в ячейке "AL1"). Если в этой строке Q есть символ "*" (символ хранится в ячейке "AK2"). Затем дважды подчеркните ячейки A через AF в этом ряду продолжайте сканирование до последнего ряда.

    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

Это то, что вы пытаетесь? Я прокомментировал код, чтобы у вас не было проблем с его пониманием. Если вы все еще делаете или получаете ошибку, просто дайте мне знать:)

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

Скриншот

Answer 2

Версия автофильтра:

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

---

Чтобы выполнить его для каждого события OnCahange одного конкретного листа, добавьте его в свой модуль VBA:

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

---

Чтобы выполнить его для всех листов в файле, добавьте его в модуль VBA для 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