SOLVED

Use a macro to achieve conditional formating.

Copper Contributor

I need to format a generated document by adding a blank line and formatting 3 cells with a top line boarder all based on the text of cells in a separate column.  I want to use a macro that is stored in the personal macro file as a new report is generated daily.  I have a routine that will add the blank line but can't get the boarder included.

 

If a cell in column D = "Department Totals"

    format the same cells in column E:G with top boarder

    insert blank row after that row.

7 Replies

@BYahr1512 

How about this?

 

Sub FormatTotalCell()
Dim rng As Range
Dim r   As Long
With ActiveSheet
    Set rng = .Columns("D").Find(what:="Department Totals", lookat:=xlWhole)
    If Not rng Is Nothing Then
        r = rng.Row
        .Rows(r + 1).Insert
        With .Range("E" & r & ":G" & r).Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .Weight = xlMedium
        End With
    Else
        MsgBox "No cell in column D contains 'Department Totals' in it.", vbExclamation
    End If
End With
End Sub

 

This was a step in the right direction.  I experienced two problems.  First, only the first time "department total" was in column D were the adjustments made.  This happens 300 to 400 times in this report.  Also when I copied it into the personal macro file it somehow messed with the regular replace command in Excel.  I would also like to assign a short cut key for this macro.  Perhaps Ctrl+Shift+Q.

best response confirmed by BYahr1512 (Copper Contributor)
Solution

@BYahr1512 

Okay, give this a try and I am sure this will take care of both the issue you reported.

 

Sub FormatTotalCell()
Dim rng         As Range
Dim r           As Long
Dim fAddress    As String

Application.ScreenUpdating = False

With ActiveSheet
    Set rng = .Columns("D").Find(what:="Department Totals", LookAt:=xlWhole)
    If Not rng Is Nothing Then
        fAddress = rng.Address
        Do
        r = rng.Row
        .Rows(r + 1).Insert
        With .Range("E" & r & ":G" & r).Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .Weight = xlMedium
        End With
        Set rng = .Columns("D").FindNext(rng)
        Loop While Not rng Is Nothing And fAddress <> rng.Address
    Else
        MsgBox "No cell in column D contains 'Department Totals' in it.", vbExclamation
    End If
End With
ResetFindAndReplace
Application.ScreenUpdating = True
End Sub

Sub ResetFindAndReplace()
    Dim r As Range

    On Error Resume Next
    Set r = ActiveCell
    On Error GoTo 0

    Cells.Find what:="", _
               After:=ActiveCell, _
               LookIn:=xlFormulas, _
               LookAt:=xlPart, _
               SearchOrder:=xlByRows, _
               SearchDirection:=xlNext, _
               MatchCase:=False, _
               SearchFormat:=False
    Cells.Replace what:="", Replacement:="", ReplaceFormat:=False

    If Not r Is Nothing Then r.Select
    Set r = Nothing
End Sub

 

 

You will need to assign the shortcut key to run this macro on your end and to do so, press Alt+F8 to open Macro list, choose the desired macro from the list, click on Options and in there set the desired shortcut key.

 

If that takes care of your original question, please don't forget to accept the post with the proposed solution as a Best Response to mark your question as Solved.

 

@Subodh_Tiwari_sktneer 

Thank you for taking the time to provide information.   On the first attempt this did not give the desired results.  It appears that when copied into the personal file it is two separate sets of instructions and the results returned were "No Department Total found in Column D".  I'll get a chance to work with this again Fri and Sat.

@BYahr1512 

If the macro doesn't find any cell in column D is not equal to the text "Department Totals" it will prompt you with the following message...

"No cell in column D contains 'Department Totals' in it."

 

Please remember it's not a partial match but the whole cell content is to be matched.

@Subodh_Tiwari_sktneer 

YAY!  Its working.  Thanks for the assist.

You're welcome @BYahr1512! Glad it worked as desired.

1 best response

Accepted Solutions
best response confirmed by BYahr1512 (Copper Contributor)
Solution

@BYahr1512 

Okay, give this a try and I am sure this will take care of both the issue you reported.

 

Sub FormatTotalCell()
Dim rng         As Range
Dim r           As Long
Dim fAddress    As String

Application.ScreenUpdating = False

With ActiveSheet
    Set rng = .Columns("D").Find(what:="Department Totals", LookAt:=xlWhole)
    If Not rng Is Nothing Then
        fAddress = rng.Address
        Do
        r = rng.Row
        .Rows(r + 1).Insert
        With .Range("E" & r & ":G" & r).Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .Weight = xlMedium
        End With
        Set rng = .Columns("D").FindNext(rng)
        Loop While Not rng Is Nothing And fAddress <> rng.Address
    Else
        MsgBox "No cell in column D contains 'Department Totals' in it.", vbExclamation
    End If
End With
ResetFindAndReplace
Application.ScreenUpdating = True
End Sub

Sub ResetFindAndReplace()
    Dim r As Range

    On Error Resume Next
    Set r = ActiveCell
    On Error GoTo 0

    Cells.Find what:="", _
               After:=ActiveCell, _
               LookIn:=xlFormulas, _
               LookAt:=xlPart, _
               SearchOrder:=xlByRows, _
               SearchDirection:=xlNext, _
               MatchCase:=False, _
               SearchFormat:=False
    Cells.Replace what:="", Replacement:="", ReplaceFormat:=False

    If Not r Is Nothing Then r.Select
    Set r = Nothing
End Sub

 

 

You will need to assign the shortcut key to run this macro on your end and to do so, press Alt+F8 to open Macro list, choose the desired macro from the list, click on Options and in there set the desired shortcut key.

 

If that takes care of your original question, please don't forget to accept the post with the proposed solution as a Best Response to mark your question as Solved.

 

View solution in original post