Excel: Format sheet based on first column

This macro takes the first column of an Excel spreadsheet and formats it in accordance with the indent level. It then groups the rows so they can be expanded and collapsed in a tree view.

This macro takes the Outline Level (a number which is the outline level of that column) of an Excel spreadsheet and formats it in accordance with the indent level. It then groups the rows so they can be expanded and collapsed in a tree view.

Sub colourByNumber()

Dim Rng As Range

Dim WorkRng As Range

Dim HeadingRng As Range

Dim FileName As Range

Dim StartCell As Range

Dim EndCell As Range

Dim ws As Worksheet

Set ws = ActiveSheet

' On Error Resume Next

Set WorkRng = Application.Selection

If WorkRng.Count = 1 Then ' Preselect the Outline Level column

Set HeadingRng = WorkRng.CurrentRegion.Rows(1).Find("Outline Level")

If Not (HeadingRng Is Nothing) Then

Set StartCell = WorkRng.CurrentRegion.Cells(2, HeadingRng.Column)

Set EndCell = WorkRng.CurrentRegion.Cells(WorkRng.CurrentRegion.Rows.Count - 1, HeadingRng.Column)

Set WorkRng = ws.Range(StartCell, EndCell)

End If

End If

xTitleId = "Select the cells which contain the Outline Level (numeric)"

Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)

For Each cell In WorkRng

If Cells(cell.Row + 1, cell.Column).Value > cell.Value Then

If cell.Value = 1 Then

cell.EntireRow.Interior.Color = RGB(0, 32, 96)

cell.EntireRow.Font.Bold = True

cell.EntireRow.Font.Color = RGB(255, 255, 255)

End If

End If

Next

For Each cell In WorkRng

If Cells(cell.Row + 1, cell.Column).Value > cell.Value Then

If cell.Value = 2 Then

cell.EntireRow.Interior.Color = RGB(0, 112, 192)

cell.EntireRow.Font.Bold = True

cell.EntireRow.Font.Color = RGB(255, 255, 255)

End If

End If

Next

For Each cell In WorkRng

If Cells(cell.Row + 1, cell.Column).Value > cell.Value Then

If cell.Value = 3 Then

cell.EntireRow.Interior.Color = RGB(0, 176, 240)

cell.EntireRow.Font.Bold = True

cell.EntireRow.Font.Color = RGB(255, 255, 255)

End If

End If

Next

For Each cell In WorkRng

If Cells(cell.Row + 1, cell.Column).Value > cell.Value Then

If cell.Value = 4 Then

cell.EntireRow.Interior.Color = RGB(41, 199, 255)

cell.EntireRow.Font.Bold = True

cell.EntireRow.Font.Color = RGB(255, 255, 255)

End If

End If

Next

For Each cell In WorkRng

If Cells(cell.Row + 1, cell.Column).Value > cell.Value Then

If cell.Value = 5 Then

cell.EntireRow.Interior.Color = RGB(41, 199, 255)

cell.EntireRow.Font.Bold = True

cell.EntireRow.Font.Color = RGB(255, 255, 255)

End If

End If

Next

For Each cell In WorkRng

If Cells(cell.Row + 1, cell.Column).Value > cell.Value Then

If cell.Value = 6 Then

cell.EntireRow.Interior.Color = RGB(253, 233, 217)

cell.EntireRow.Font.Bold = True

End If

End If

Next

For Each cell In WorkRng

cell.EntireRow.OutlineLevel = cell.Value

Next

ActiveSheet.Outline.SummaryRow = xlAbove

End Sub

The colours below are based on Prima Vera defaults:

Sub go()

SelectColumn

ConvertSpacesToIndents

Colour

CreateGroupingsOnIndents

End Sub

Sub ConvertSpacesToIndents()

Dim cell As Range

Dim currentIndent As Integer ' Fix Prima Vera problem

currentIndent = 0 ' Fix Prima Vera problem

If (Selection.Rows.Count = 1) And (Selection.Columns.Count = 1) Then

MsgBox ("Select the cells you wish to group by indent.")

Exit Sub

End If

ConvertIndentsToSpaces ' Required to stop losing indents on items already indented

For Each cell In Selection

Dim ttOrig As String

Dim ttNew As String

ttOrig = cell.Text

ttNew = LTrim(ttOrig)

cell.IndentLevel = (Len(ttOrig) - Len(ttNew)) / 2

If (cell.IndentLevel = 0) And (IsNumeric(cell) = True) Then ' This If section is to fix lines that are only numbers, a particular problem that Prima Vera has.

cell.IndentLevel = currentIndent + 1

Else

currentIndent = cell.IndentLevel

End If

cell.Value = ttNew

Next

End Sub

Sub ConvertIndentsToSpaces()

Dim cell As Range

For Each cell In Selection

Dim ttOrig As String

Dim ttNew As String

ttNew = cell.Text

For i = 1 To cell.IndentLevel

ttNew = " " & ttNew

Next

cell.Value = ttNew

cell.IndentLevel = 0

Next

End Sub

Sub Colour()

For Each cell In Selection

If Cells(cell.Row + 1, cell.Column).IndentLevel > cell.IndentLevel Then

If cell.IndentLevel = 0 Then

cell.EntireRow.Interior.Color = RGB(128, 255, 128)

cell.EntireRow.Font.Bold = True

cell.EntireRow.Font.Color = RGB(0, 0, 0)

End If

End If

Next

For Each cell In Selection

If Cells(cell.Row + 1, cell.Column).IndentLevel > cell.IndentLevel Then

If cell.IndentLevel = 1 Then

cell.EntireRow.Interior.Color = RGB(255, 255, 0)

cell.EntireRow.Font.Bold = True

cell.EntireRow.Font.Color = RGB(0, 0, 255)

End If

End If

Next

For Each cell In Selection

If Cells(cell.Row + 1, cell.Column).IndentLevel > cell.IndentLevel Then

If cell.IndentLevel = 2 Then

cell.EntireRow.Interior.Color = RGB(0, 0, 255)

cell.EntireRow.Font.Bold = True

cell.EntireRow.Font.Color = RGB(255, 255, 255)

End If

End If

Next

For Each cell In Selection

If Cells(cell.Row + 1, cell.Column).IndentLevel > cell.IndentLevel Then

If cell.IndentLevel = 3 Then

cell.EntireRow.Interior.Color = RGB(255, 0, 0)

cell.EntireRow.Font.Bold = True

cell.EntireRow.Font.Color = RGB(255, 255, 255)

End If

End If

Next

For Each cell In Selection

If Cells(cell.Row + 1, cell.Column).IndentLevel > cell.IndentLevel Then

If cell.IndentLevel = 4 Then

cell.EntireRow.Interior.Color = RGB(128, 255, 255)

cell.EntireRow.Font.Bold = True

cell.EntireRow.Font.Color = RGB(0, 0, 0)

End If

End If

Next

For Each cell In Selection

If Cells(cell.Row + 1, cell.Column).IndentLevel > cell.IndentLevel Then

If cell.IndentLevel = 5 Then

cell.EntireRow.Interior.Color = RGB(253, 233, 217)

cell.EntireRow.Font.Bold = True

End If

End If

Next

End Sub

Sub SelectColumn()

Range("A1").Select

Selection.End(xlDown).Select

Selection.End(xlDown).Select

Selection.End(xlDown).Select

Selection.End(xlDown).Select

Selection.End(xlDown).Select

Selection.End(xlDown).Select

Selection.End(xlDown).Select

Selection.End(xlDown).Select

Selection.End(xlDown).Select

Selection.End(xlDown).Select

Selection.End(xlDown).Select

Selection.End(xlDown).Select

Selection.End(xlDown).Select

Selection.End(xlDown).Select

Selection.End(xlDown).Select

Selection.End(xlDown).Select

Selection.End(xlUp).Select

Range("A2", Range(Selection.Address)).Select

End Sub

Sub HighlightChanges()

With ActiveWorkbook

.HighlightChangesOptions When:=xlAllChanges

.ListChangesOnNewSheet = False

.HighlightChangesOnScreen = True

End With

End Sub

Sub CreateGroupingsOnIndents()

If ActiveWorkbook.MultiUserEditing Then

MsgBox ("This can only be done in exclusive mode (Review > Share Workbook)")

Exit Sub

End If

Dim cell As Range

'If (Selection.Rows.Count = 1) And (Selection.Columns.Count = 1) Then

' MsgBox ("Select the cells you wish to group by indent, excluding the first item.")

' Exit Sub

'End If

For Each cell In Selection

cell.EntireRow.OutlineLevel = cell.IndentLevel + 1

Next

End Sub