A more simple or efficient way of entering header row text & formatting ?

[Event2020]

Hello everyone.

I am using Windows 10 and Excel 2019.

This is my first post here and I hope to learn and maybe, in time, give back.

I use the code below to.
1. Clear all cell contents and formatting
2. Adds the text (value?) for cells A1 to AI
3. Fomats the cells
4. Freezes the top row.

It seems to be a lot of code to do what appears to be something simple.

My question is, is there a more simple or efficient way of writing the VBA code?

Many thanks



Sub TestAddHeader()


With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual

End With




' Makes Sheet5the active sheet
Sheets("Sheet5").Activate

' Clears all formulas, text and row colours
Cells.Clear
Cells.ClearFormats



Range("A1").Select
ActiveCell.FormulaR1C1 = "Title 1"

Range("B1").Select
ActiveCell.FormulaR1C1 = "Title 2"

Range("C1").Select
ActiveCell.FormulaR1C1 = "Title 3"

Range("D1").Select
ActiveCell.FormulaR1C1 = "Title 4"

Range("E1").Select
ActiveCell.FormulaR1C1 = "Title 5"

Range("F1").Select
ActiveCell.FormulaR1C1 = "Title 6"

Range("G1").Select
ActiveCell.FormulaR1C1 = "Title 7"

Range("H1").Select
ActiveCell.FormulaR1C1 = "Title 8"

Range("I1").Select
ActiveCell.FormulaR1C1 = "Title 9"


Range("A1:I1").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With

' This applies the top row (Row 1) freeze
Rows("1:1").Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
Range("A2").Select

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic

End With

End Sub

[Paul_Hossler]

This is a little more simplified

Usually you do not need to .Select some object to act on it

Just .Borders without an index applies to the outside 4




Option Explicit


Sub TestAddHeader()


With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With




' Makes Sheet5the active sheet
With Sheets("Sheet5")

' Clears all formulas, text and row colours
.Cells.Clear
.Cells.ClearFormats

.Range("A1").Value = "Title 1"
.Range("B1").Value = "Title 2"
.Range("C1").Value = "Title 3"
.Range("D1").Value = "Title 4"
.Range("E1").Value = "Title 5"
.Range("F1").Value = "Title 6"
.Range("G1").Value = "Title 7"
.Range("H1").Value = "Title 8"
.Range("I1").Value = "Title 9"

With .Range("A1:I1")
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False

With .Font
.Bold = True
End With

With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With

.Borders.LineStyle = xlContinuous
End With

.Rows("1:1").Select

' This applies the top row (Row 1) freeze
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
End With


.Range("A2").Select
End With

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With

End Sub



A less brute force way would be something like



Range("A1").Resize(1, 9).Value = Array("Title 1", "Title 2", "Title 3", "Title 4", "Title 5", "Title 6", "Title 7", "Title 8", "Title 9")

[p45cal]

…and shorter. Note that .BorderAround doesn't add internal borders (same as your original code). Many things that are recorded by the macro recorder change things that don't need changing because they're already that value/property after .Clear (which also clears formats).:
Sub TestAddHeader()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With Sheets("Sheet5")
'Clears all formulas, text and row colours **and formats**:
.Cells.Clear
With .Range("A1:I1")
.Value = Array("Title 1", "Title 2", "Title 3", "Title 4", "Title 5", "Title 6", "Title 7", "Title 8", "Title 9")
.VerticalAlignment = xlCenter
.Font.Bold = True
With .Interior
.Pattern = xlSolid
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
End With
.BorderAround xlContinuous, xlMedium
End With
End With
' This applies the top row (Row 1) freeze
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

[Event2020]

This is a little more simplified


Usually you do not need to .Select some object to act on it


Just .Borders without an index applies to the outside 4


and


…and shorter. Note that .BorderAround doesn't add internal borders (same as your original code). Many things that are recorded by the macro recorder change things that don't need changing because they're already that value/property after .Clear (which also clears formats).


Thank you Paul and p45cal


Later today I will give both of your suggestions a try.


Thank you again.

[snb]

Why not using Excel's builtin methods ?


Sub M_snb()
Cells(1) = "Title 1"
Cells(1).AutoFill Cells(1).Resize(, 9)
ListObjects.Add(1, Cells(1).Resize(, 9), , 1).Name = "Table1"
End Sub

Macro in the macromodule of the activesheet.

[Paul_Hossler]

Why not using Excel's builtin methods ?


Sub M_snb()
Cells(1) = "Title 1"
Cells(1).AutoFill Cells(1).Resize(, 9)
ListObjects.Add(1, Cells(1).Resize(, 9), , 1).Name = "Table1"
End Sub

Macro in the macromodule of the activesheet.

FWIW, I assumed that "Title 1" ... "Title 9" were just some placeholders for the question and that the real column headers would be something like "Region", "State", "City", "Street", ...

[Aussiebear]

One of the major issues with snb's code it that he never explains the code. In fact I often wonder whether he actually could explain it. One is always left with the feeling that the code may or may not work. Unfortunately experience has confirmed that snb's code generally fails. For that reason alone I tend to ignore any code provided by snb as rubbish.

[georgiboy]

If you are simply clearing the cells and adding a formatted header then I would suggest another approach. You could have a hidden sheet that contains the formatted header, this would give you the ability to format and change the header as you wish (manually and visually), without having to edit any VBA. You would then copy the header from the hidden template sheet and paste it into the required sheet. The code would be similar to the below:

Sub Test()
Dim wsHeader As Worksheet, wsTarget As Worksheet

Set wsHeader = Sheets("Header Template")
Set wsTarget = Sheets("Sheet5")

With wsTarget
.Activate
.UsedRange.Clear
wsHeader.Rows(1).Copy .Rows(1)
.Rows(2).Activate
End With
ActiveWindow.FreezePanes = True
End Sub

On another note:
If it is always 'Sheet5' that you are updating the the frozen row at the top will remain frozen even after the cells have been cleared. This means you would not need to repeat the steps to freeze the top row each time, you could freeze it once manually and then forget about it.
The code could then be shortened to:

Sub Test1()
Dim wsHeader As Worksheet, wsTarget As Worksheet

Set wsHeader = Sheets("Header Template")
Set wsTarget = Sheets("Sheet5")

With wsTarget
.UsedRange.Clear
wsHeader.Rows(1).Copy .Rows(1)
End With
End Sub

Or even shorter:

Sub Test2()
Sheets("Sheet5").UsedRange.Clear
Sheets("Header Template").Rows(1).Copy Sheets("Sheet5").Rows(1)
End Sub

See attached file (remember the 'Header Template' sheet can be hidden)

[Event2020]

Thank you everyone for your kind suggestions and they are very much appreciated.

I will try them all out in turn.