Sub RestoreIndents()
' Restore indents based on cell to the left
Dim cell As Range
For Each cell In Selection
cell.IndentLevel = cell.Offset(0, -1).Value
Next
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
Sub CreateIndentsOnGrouping()
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.IndentLevel = cell.EntireRow.OutlineLevel - 1
Next
End Sub
Function that can be used in a cell to determine the indent level
Function indentShow(CellObject As Range) As Integer
indentShow = CellObject.IndentLevel
End Function
Or if you're using spaces:
' Select a cell which you will place the calculated result at, and type this formula =FIND(LEFT(TRIM(A1),1),A1)-1
Sub CreateGroupingsOnNumber()
' Create groupings based on selected numbers in cells
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
On Error Resume Next
For Each cell In Selection
If CSng(cell.text) = 1 Or CSng(cell.text) = 0 Or cell.text = "" Then
cell.EntireRow.ClearOutline
Else
cell.EntireRow.OutlineLevel = CSng(cell.text)
End If
Next
End Sub
Groupings based on spaces (Project 2010)
Sub CreateGroupingsOnSpaces()
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
Dim ttOrig As String
Dim ttNew As String
ttOrig = cell.Text
ttNew = LTrim(ttOrig)
cell.EntireRow.OutlineLevel = (Len(ttOrig) - Len(ttNew)) / 3 + 1
Next
End Sub
Convert spaces to indents and convert indents to spaces (Project 2010)
Sub ConvertSpacesToIndents()
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.")
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)) / 3
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
'http://www.mrexcel.com/forum/excel-questions/520950-visual-basic-applications-group-rows-wbs-ms-project.html
Sub DecimalToIndent()
Dim Rng1 As Range 'numbers
Dim rng2 As Range 'descriptions
Dim NumCol As Long
Dim DescCol As Long
Dim TopRow As Long
Dim BotRow As Long
Dim AdStr As String
Dim i As Long
Dim j As Long
Dim k As Long
Set Rng1 = Application.InputBox(prompt:="select the numbers to use as a basis for indentation", Type:=8)
Set rng2 = Application.InputBox(prompt:="select the descriptions to be indented", Type:=8)
AdStr = CStr(Rng1.Address)
AdStr = Left(AdStr, Application.WorksheetFunction.Find(":", AdStr, 1) - 1)
TopRow = Range(AdStr).Row
NumCol = Range(AdStr).Column
AdStr = CStr(rng2.Address)
AdStr = Right(AdStr, Len(AdStr) - Application.WorksheetFunction.Find(":", AdStr, 1))
BotRow = Range(AdStr).Row
DescCol = Range(AdStr).Column
For i = TopRow To BotRow
k = 0
For j = 1 To Len(Cells(i, NumCol))
If Mid(Cells(i, NumCol), j, 1) = "." Then k = k + 1
Next j
Cells(i, DescCol).IndentLevel = k
Next i
End Sub
Sub IndentBasedOnPeriods()
'Indent Task Name column based upon the count of periods in the WBS field
Dim i As Long
For i = 1 To Range("setWBSCount").Count
'Indent each cell by the number of periods found in the WBS
If Range("AD2").Offset(i, 0).Value > 0 Then
Range("E2").Offset(i).IndentLevel = Range("AD2").Offset(i, 0).Value * 2
End If
Next i
End Sub
'http://www.mrexcel.com/forum/excel-questions/520950-visual-basic-applications-group-rows-wbs-ms-project.html
Sub IndentBasedOnWBSLevel()
'If the wbs level (1 ... N) is in col A
Dim cell As Range
Rows.ClearOutline
For Each cell In Range("A2", Cells(Rows.Count, "A").End(xlUp))
cell.EntireRow.OutlineLevel = cell.Value
Next cell
End Sub
Add WBS style number to the first column:
Sub NumberWBS()
' Add WBS numbering to the first column.
' To use: Select 2 columns, the first is the column to be numbered,
' the second is the indented task description.
' Edward Chan 2016
Dim lvl1Counter As Integer
Dim lvl2Counter As Integer
Dim lvl3Counter As Integer
Dim InLevel As Integer
Dim WBSno As String
lvl1Counter = 0
lvl2Counter = 0
lvl3Counter = 0
Dim x As Range
Set x = Selection
For i = 1 To x.Rows.Count
Select Case x.Cells(i, 2).IndentLevel
Case 0
lvl1Counter = lvl1Counter + 1
lvl2Counter = 0
lvl3Counter = 0
WBSno = lvl1Counter
Case 1
lvlCounter1 = lvl1Counter
lvl2Counter = lvl2Counter + 1
lvl3Counter = 0
WBSno = lvl1Counter & "." & lvl2Counter
Case 2
lvlCounter1 = lvl1Counter
lvl2Counter = lvl2Counter
lvl3Counter = lvl3Counter + 1
WBSno = lvl1Counter & "." & lvl2Counter & "." & lvl3Counter
End Select
x.Cells(i, 1).Value = "'" & WBSno
Next i
End Sub