Embedded Files
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
Page updated
Google Sites
Report abuse