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

Siddharth Rout · Accepted Answer · 2015-09-09T06:19:34.270

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

Thank you very much for helping me Siddharth. That code is very nice and is almost perfect. the only issue is that it only selects the first "*". The "*" shows up multiple times in col q at random intervals. everything else is perfect. Thanks again and hopefully its just a minor change. As for the orginal code it was many pieces of many unsuccessful google searches. Thanks for the tips. I used them in the rest of the macro that this is a part of — Alberto Brown, Sep 08 '15 at 23:49
Thank you, the code is now perfect and does exactly.What I want. I'll ask you the same question I did in the other answer that worked. Is there anyway to make this macro always on. so that as soon as the * is typed the underline appears? — Alberto Brown, Sep 09 '15 at 12:54
[THIS](http://stackoverflow.com/questions/13860894/ms-excel-crashes-when-vba-code-runs/13861640#13861640) will get you started. If you are stuck then feel free to ask a new question. Hope I have answered your main query here? — Siddharth Rout, Sep 09 '15 at 12:55
I added the code found on that link but it doesn't appear to run the code all the time. I dont know if I need to unlink the macro from the button I created or if I need to insert the autrun code and the underline code into a new module. I'll try again in a bit and let you know — Alberto Brown, Sep 10 '15 at 12:35

paul bica · Answer 2 · 2015-09-10T18:31:19.437

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

edited Sep 10 '15 at 18:31

answered Sep 09 '15 at 02:58

paul bica

10,557
4
23
42

1

Thanks @PaulBica, this option did work almost perfectly and quite rapidly. Thank you for reminding me to use screenupdating to speed things up. I have many cobwebs on my macro skills, thanks for the code. If there are two * in a row sometimes the code doesn't grab the first or the second. Do I need to modify the offset to correct this? Also this macro may be run multiple times on the same sheet is there anyway to have this "always running" / as soon as * is placed in Col Q the macro will auto format that row? Sorry for all the follow ups but I like to make things idiot proof – Alberto Brown Sep 09 '15 at 12:44
I updated the answer to fix the issue you mentioned and to allow it to be "on" all the time - thanks for the feedback! – paul bica Sep 09 '15 at 16:06
I inserted a new module and input the first option you presented and it doesn't seem to be working. I'll try again after my meeting, But again thank you for the help – Alberto Brown Sep 10 '15 at 12:33
`Worksheet_Change()` has to go in the module for the **sheet** (not a new VBA module) - so if you want to update Sheet1, open VBA module for Sheet1 (under "Microsoft Excel Objects", not "Modules") – paul bica Sep 10 '15 at 12:57
That was my problem and again Thanks. The auto update is perfect now. Like I said lots of cobwebs but now this project is idiot proof for the most. – Alberto Brown Sep 10 '15 at 17:05
1

The auto update works very well, my only issue is I run into an error if I try to clear the data on the page or use my other macro to place data on the page " runtime error 13 type mismatch " Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) 'restrict the call to column Q only, and if the new value is same as cell AK2 If Target.Column = 17 And Target.Value2 = Me.Range("AK2").Value2 Then 'this is where the debugger highlights 'showSymbol code End If End Sub – Alberto Brown Sep 10 '15 at 17:28
I updated the last 2 subs to execute only when you edit one cell. Replace `Worksheet_Change()` with the latest one and try clearing the data on the page (or placing data on it) – paul bica Sep 10 '15 at 18:33

Macro double underline range if col q = *

2 Answers2