07-13-2020 09:43 AM
07-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.
07-14-2020 07:55 PM - edited 07-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
07-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.
07-15-2020 10:26 AM - edited 07-15-2020 10:28 AMSolution
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.
07-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.
07-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.