Jul 13 2020 09:43 AM
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.
Jul 14 2020 07:55 PM - edited Jul 14 2020 07:59 PM
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
Jul 15 2020 10:01 AM
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.
Jul 15 2020 10:26 AM - edited Jul 15 2020 10:28 AM
SolutionOkay, 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.
Jul 16 2020 09:50 AM
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.
Jul 16 2020 11:41 AM
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.
Jul 18 2020 04:18 AM
YAY! Its working. Thanks for the assist.
Jul 18 2020 04:46 AM
You're welcome @BYahr1512! Glad it worked as desired.
Jul 15 2020 10:26 AM - edited Jul 15 2020 10:28 AM
SolutionOkay, 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.