MS project VBA - Setting Formating In Excel - excel

I am trying to use the following code which is run from MS Project to populate an xls sheet.
As part of that I want to set formating including some merging & font setting.
I have 2 issues:
1) "Application.CutCopyMode = False" runs ok in xls but fails when I use the code in MS Project
2) Formating set out is not applied to the cells but does not error
Any thoughts ?
Thanks
Terran
'add the task details from row i onwards
'Removes tasks that are complete and not valid such as roll ups
For Each t In pj.Tasks
If t.Rollup = False Then
If t.Milestone = True Then
If t.Text18 Like "" Then
If t.Text19 Like "" Then
i = i + 1
'merge the 1st 2 cells
'ActiveSheet.Range(i2, i4).Select
' https://learn.microsoft.com/en-us/office/troubleshoot/office-developer/select-cells-rangs-with-visual-basic
'ActiveSheet.Cells(i, 2).Select
'With Selection
' .HorizontalAlignment = xlLeft
' .VerticalAlignment = xlBottom
' .WrapText = False
' .Orientation = 0
' .AddIndent = False
' .IndentLevel = 0
' .ShrinkToFit = False
' .ReadingOrder = xlContext
' .MergeCells = True
'End With
'put the values in the cells & set font
ActiveSheet.Cells(i, 2).Select
With Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
' ------
ActiveSheet.Cells(i, 5).Select
With Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
'change number formnat
With Selection.NumberFormat = "d/m/yyyy"
End With
' ------
ActiveSheet.Cells(i, 6).Select
With Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
'change number formnat
With Selection.NumberFormat = "d/m/yyyy"
End With
' ------
ActiveSheet.Cells(i, 7).Select
With Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
'change number formnat
With Selection.NumberFormat = "d/m/yyyy"
End With
' ------
ActiveSheet.Cells(i, 8).Select
With Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
'change number formnat
With Selection.NumberFormat = "d/m/yyyy"
End With
' ------
ActiveSheet.Cells(i, 2).Select
With Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
'change number formnat
With Selection.NumberFormat = "d/m/yyyy"
End With
' ------
ActiveSheet.Cells(i, 9).Select
With Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
'change number formnat
With Selection.NumberFormat = "d/m/yyyy"
End With
' ------
ActiveSheet.Cells(i, 10).Select
With Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
'change number formnat
With Selection.NumberFormat = "d/m/yyyy"
End With
xlSheet.Cells(i, 2).Value = t.Name
xlSheet.Cells(i, 5).Value = t.BaselineStart
xlSheet.Cells(i, 6).Value = t.BaselineFinish
xlSheet.Cells(i, 7).Value = t.Start
xlSheet.Cells(i, 8).Value = t.Finish
xlSheet.Cells(i, 9).Value = t.ActualStart
xlSheet.Cells(i, 10).Value = t.ActualFinish
'xlSheet.Cells(i, 11).Value = t.Notes
End If
End If
End If
End If
Next t

Related

What's the vba code to change the color of the first line in multiple excel sheets from 6 onwards?

I need to format (create a title, select the vendor code according to the table...) a set of cells at the beginning of each sheet from sheet 6. I already have the VBA code to insert the lines above the table, now I just needed the code to format the cells from sheet 6 at the same time. Can anyone help me?
My code for inserting lines is as follows:
Sub insert_rows()
Application.DisplayAlerts = False
Dim i As Integer, a As Integer
a = 6
For i = Sheets.Count To 6 Step -1
If Sheets.Count = 6 Then
Exit Sub
End If
a = a + 1
Sheets(i).Range("1:1").Insert
Sheets(i).Range("2:2").Insert
Sheets(i).Range("3:3").Insert
Sheets(i).Range("4:4").Insert
Sheets(i).Range("5:5").Insert
Sheets(i).Range("6:6").Insert
Sheets(i).Range("7:7").Insert
Sheets(i).Range("8:8").Insert
Application.DisplayAlerts = True
Next
End Sub
The formatting I want is the one below. I need the code to apply this formatting from sheet 6 onwards, because the first sheets are support sheets for the tables and, therefore, do not need this "header".
Sub Format()
'
' Format Macro
Range("B1:J2").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("B1:J2").Select
With Selection.Font
.Color = -10066432
.TintAndShade = 0
End With
Range("B1:J2").Select
ActiveCell.FormulaR1C1 = "TITLE"
Range("B4").Select
ActiveCell.FormulaR1C1 = "Name:"
Range("B5").Select
ActiveCell.FormulaR1C1 = "Code:"
Range("B6").Select
ActiveCell.FormulaR1C1 = "Date:"
Range("C4").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("C5").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("C6").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
ActiveWindow.DisplayGridlines = False
End Sub
Thank you!

How to Get Rid of Select/Activate When Possible
Option Explicit
Sub CreateHeadersAfterSheet5()
Const ProcName As String = "CreateHeadersAfterSheet5"
On Error GoTo ClearError
Const FirstWorksheetIndex As Long = 6
Application.ScreenUpdating = False
With ThisWorkbook
Dim LastWorksheetIndex As Long: LastWorksheetIndex = .Worksheets.Count
If LastWorksheetIndex < FirstWorksheetIndex Then Exit Sub
Dim ash As Object: Set ash = .ActiveSheet
Dim n As Long
For n = FirstWorksheetIndex To LastWorksheetIndex
CreateHeaders .Worksheets(n)
Next n
ash.Select
End With
Application.ScreenUpdating = True
MsgBox "Headers created."
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
Sub CreateHeaders(ByVal ws As Worksheet)
Const ProcName As String = "CreateHeaders"
On Error GoTo ClearError
With ws
.Select ' cannot be avoided only because of the following line
ActiveWindow.DisplayGridlines = False
.Range("1:8").Insert
With .Range("B1:J2")
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
'.MergeCells = True
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
With .Font
.Color = -10066432
.TintAndShade = 0
End With
End With
.Range("B1").Value = "TITLE"
.Range("B4").Value = "Name:"
.Range("B5").Value = "Code:"
.Range("B6").Value = "Date:"
With .Range("C4")
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
With .Range("C5")
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
With .Range("C6")
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
End With
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub

Q: Use VBA to create a new Pivot TableStyle

I recorded a macro to create a new Pivot Table style so that whenever I create a new worksheet, this Pivot Table Style is added as the default for the Workbook. However, it does not seem to work when I try to run it on a new workbook. At first, I thought it might be the names (i.e. Sheet1), but even when everything matches it errors out on the first line. I hate having to go in and add this new pivot table style to every report I make, so if anyone has any tips, I'd greatly appreciate it. I'm a complete novice at VBA, so if there are any suggestions for making this code shorter, that would be of great help too!
EDIT: The code does not have curly quotations - that was me renaming it for posting.
Additional Edit: This is the error I get:
VBA Error: Run-time error '5': invalid procedure call or arguement
When I hit Debug, it takes me to the first line of code, which is highlighted in yellow: ActiveWorkbook.TableStyles.Add (“Overview”)
Sub Overview_Pivot_Format()
'
' Overview_Pivot_Format Macro
'
'
ActiveWorkbook.TableStyles.Add (“Overview”)
With ActiveWorkbook.TableStyles(“Overview”)
.ShowAsAvailablePivotTableStyle = True
.ShowAsAvailableTableStyle = False
.ShowAsAvailableSlicerStyle = False
.ShowAsAvailableTimelineStyle = False
End With
ActiveWorkbook.DefaultPivotTableStyle = “Overview”
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlWholeTable).Borders(xlEdgeTop)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlWholeTable).Borders(xlEdgeBottom)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlWholeTable).Borders(xlEdgeLeft)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlWholeTable).Borders(xlEdgeRight)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlWholeTable).Borders(xlInsideVertical)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlWholeTable).Borders(xlInsideHorizontal)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlHeaderRow).Interior
.Color = 15658734
.TintAndShade = 0
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlHeaderRow).Borders(xlEdgeTop)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlHeaderRow).Borders(xlEdgeBottom)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlHeaderRow).Borders(xlEdgeLeft)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlHeaderRow).Borders(xlEdgeRight)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlHeaderRow).Borders(xlInsideVertical)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlHeaderRow).Borders(xlInsideHorizontal)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlTotalRow).Font
.FontStyle = "Bold"
.TintAndShade = 0
.ThemeColor = xlThemeColorDark1
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlTotalRow).Interior
.Color = 6697728
.TintAndShade = 0
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlSubtotalRow1).Font
.FontStyle = "Bold"
.TintAndShade = 0
.ThemeColor = xlThemeColorDark1
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlSubtotalRow1).Interior
.Color = 6697728
.TintAndShade = 0
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlSubtotalRow2).Font
.FontStyle = "Bold"
.TintAndShade = 0
.ThemeColor = xlThemeColorDark1
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlSubtotalRow2).Interior
.Color = 6697728
.TintAndShade = 0
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlSubtotalRow3).Font
.FontStyle = "Bold"
.TintAndShade = 0
.ThemeColor = xlThemeColorDark1
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlSubtotalRow3).Interior
.Color = 6697728
.TintAndShade = 0
End With
End Sub

The below worked for me:
Sub Overview_Pivot_Format()
Dim ts As TableStyle, wb As Workbook
Set wb = ActiveWorkbook 'workbook to be updated
On Error Resume Next 'ignore error if no style found in next line
wb.TableStyles("OverView").Delete 'in case already present
On Error GoTo 0 'stop ignoring errors
Set ts = wb.TableStyles.Add("Overview") 'get a reference to the added style
With ts
.ShowAsAvailablePivotTableStyle = True
.ShowAsAvailableTableStyle = False
.ShowAsAvailableSlicerStyle = False
.ShowAsAvailableTimelineStyle = False
End With
wb.DefaultPivotTableStyle = ts
'set properties by calling the 3 subs below...
DoBorders ts.TableStyleElements(xlWholeTable)
DoInterior ts.TableStyleElements(xlHeaderRow), 15658734
DoBorders ts.TableStyleElements(xlHeaderRow)
DoInterior ts.TableStyleElements(xlTotalRow), 6697728
DoFont ts.TableStyleElements(xlTotalRow)
DoInterior ts.TableStyleElements(xlSubtotalRow1), 6697728
DoFont ts.TableStyleElements(xlSubtotalRow1)
DoInterior ts.TableStyleElements(xlSubtotalRow2), 6697728
DoFont ts.TableStyleElements(xlSubtotalRow2)
DoInterior ts.TableStyleElements(xlSubtotalRow3), 6697728
DoFont ts.TableStyleElements(xlSubtotalRow3)
End Sub
'next 3 sub take care of updating the styles...
Sub DoFont(tse As TableStyleElement)
With tse.Font
.FontStyle = "Bold"
.TintAndShade = 0
.ThemeColor = xlThemeColorDark1
End With
End Sub
Sub DoBorders(tse As TableStyleElement)
With tse.Borders() 'no need to set individually...
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
End Sub
Sub DoInterior(tse As TableStyleElement, clr As Long)
With tse.Interior
.Color = clr
.TintAndShade = 0
End With
End Sub

Loop through a worksheet and insert a row with layout when value is true

I have a code that does a loop through a worksheets, if there is a value 2 inside a cell in column S, then I want to insert a row with a specific layout. I have the code, but it takes ages to complete. I've tried replacing .select function, but because I need a specific layout, I don't know how to avoid this.
LastRowMatchC = Worksheets("Compliance").Cells(Rows.Count, 1).End(xlUp).Row
Dim rngc As Range, rc As Long
Set rngc = Range("S8:S" & LastRowMatchC)
For rc = rngc.Count To 1 Step -1
If rngc(rc).Value = 2 Then
rngc(rc + 1).EntireRow.Insert
rngc(rc + 1).EntireRow.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.599993896298105
.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 = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End If
Next rch

Adding all borders to a selected range, is there a shorter way to write the code?

I am adding all borders to a certain range, In my case (A6:O6),in excel VBA, the below code works but I'd imagine there would have to be a shorter way to write it. I found a single line of code that puts a border around the whole selection but not around every cell.
Range("A6:O6").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

You can use the below statements
Dim myRange As Range
Set myRange = Range("A6:O6")
With myRange.Borders
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

Try this. It will add a border around every cell in the range A6:O6.
Sub Macro1()
Dim rng As Range
' Define range
Set rng = Range("A6:O6")
With rng.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 0
.TintAndShade = 0
End With
End Sub

Add gridlines to an Excel sheet

In the below code, how can I add grid-lines to the entire Excel sheet?
Set objApp = CreateObject("Excel.Application")
objApp.Visible = True
Set wb = objApp.Workbooks.Open("template.xls", True, False)
wb.Sheets(1).Rows(3).Delete
wb.Sheets(1).Range("A1").Value = title
'need to format column E & F as currency
Set objApp = Nothing

This is the long answer (the code Excel VBA generates when you record a Macro). You can definitely shorten this up. For instance, you don't need to set the .ColorIndex or .TintAndShade properties just to do a standard black [edit] border.
Cells.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
EDIT
For gridlines:
ActiveWindow.DisplayGridlines = True
you can also use:
Windows(1).DisplayGridlines = True

Try this:
ActiveWindow.DisplayGridlines = True
That should turn the gridlines on. And, of course, setting the property to False will turn them off.

Resources