Add WBS text to cell comment note

[gailb]

The tab Test Sheet is the before and Test Sheet 2 is the after. I have a macro built (Sub InsertFormula) which inserts a column in D and copies all of the level 4's. Then create another column and uses TextJoin to create the join of all the level 4's at the 3rd level. This works fine, but it would be nice to create the textjoin without having to create the additional columns. Can it be constructed and placed in the comments straight from column C?

Code is attached in sample workbook.

test workbook.xlsm

[p45cal]

try the following which includes the functionality of all your subs:

Code: Select all

Sub InsertFormula2()
Dim ws      As Worksheet
Dim LastRow As Long
Dim myRow   As Long
Dim myComment As String, NextRow As Long, x
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Test Sheet 3").Delete
On Error GoTo 0
Application.DisplayAlerts = True

Sheets("Test Sheet").Copy After:=Worksheets(Sheets.Count): ActiveSheet.Name = "Test Sheet 3"
    
Set ws = Sheets("Test Sheet 3")
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    
Application.ScreenUpdating = False
    
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
    
ws.UsedRange.ClearComments
For myRow = 2 To LastRow
  If ws.Range("A" & myRow).Value = 3 Then
    myComment = ""
    NextRow = myRow + 1
    Do Until ws.Range("A" & NextRow).Value <> 4
      myComment = myComment & "(" & ws.Range("B" & NextRow).Value & ") " & ws.Range("C" & NextRow).Value & vbLf
      NextRow = NextRow + 1
    Loop
    With ws.Range("C" & myRow)
      .AddComment Left(myComment, Len(myComment) - 1)
      With .Comment.Shape.TextFrame.Characters.Font
        .Name = "Arial Nova Light"
        .Size = 12
      End With
      .Comment.Shape.TextFrame.AutoSize = True
    End With
  End If
'indent:
  x = ws.Range("A" & myRow).Value
  Select Case x
  Case 2 To 4: ws.Range("B" & myRow).Resize(, 2).IndentLevel = x - 1
  End Select
Next myRow
Application.ScreenUpdating = True
End Sub

[HansV]

Staying closer yo your code:

Code: Select all

Sub InsertFormula()
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("Test Sheet 2").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    Sheets("Test Sheet").Copy After:=Worksheets(Sheets.Count): ActiveSheet.Name = "Test Sheet 2"
    
    Dim ws      As Worksheet: Set ws = Sheets("Test Sheet 2")
    Dim LastRow As Long: LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    Dim myRow   As Long
    Const MyCol As String = "D"
    
    Application.ScreenUpdating = False
    
    If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
    
    ws.UsedRange.ClearComments
    Call CreateComments
    Call AddIndent
    
    Application.ScreenUpdating = True
End Sub

Sub CreateComments()
    Dim LastRow As Long, r As Long
    Dim s As String
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    For r = LastRow To 2 Step -1
        Select Case Range("A" & r).Value
            Case 3
                Range("C" & r).AddComment Mid(s, 3)
            With Range("C" & r).Comment.Shape.TextFrame
                With .Characters.Font
                    .Name = "Arial Nova Light"
                    .Size = 12
                End With
                .AutoSize = True
            End With
            s = ""
            Case 4
                s = s & vbCrLf & Range("B" & r).Value & " " & Range("C" & r).Value
        End Select
    Next r
End Sub

Public Sub AddIndent()
    Const MyCol     As String = "B"
    Const StartRow  As Long = 2
    Dim myRow       As Long
    Dim x           As Long
    With Sheets("Test Sheet 2")
       Dim LastRow As Long: LastRow = .Range(MyCol & .Rows.Count).End(xlUp).Row
        For myRow = StartRow To LastRow
            x = .Range("A" & myRow).Value
            Select Case x
                Case 2: .Range(MyCol & myRow).Resize(, 2).IndentLevel = 1
                Case 3: .Range(MyCol & myRow).Resize(, 2).IndentLevel = 2
                Case 4: .Range(MyCol & myRow).Resize(, 2).IndentLevel = 3
            End Select
        Next myRow
    End With
End Sub

[gailb]

Thank you to you both. These are both great options.

@Hans, with your code, the string results in the comment are inverted. Also, I simply can't understand what the Mid(s, 3) is doing?

[snb]

Code: Select all

Sub M_snb()
  sn = Sheet3.Cells(1).CurrentRegion
  
  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sn)
      sn(j, 2) = Space(2 * sn(j, 1)) & sn(j, 2)
      sn(j, 3) = Space(2 * sn(j, 1)) & sn(j, 3)
      If sn(j, 1) = 3 Then c00 = Trim(sn(j, 3))
      If sn(j, 1) = 4 Then .Item(c00) = .Item(c00) & vbLf & "(" & Trim(sn(j, 2)) & ") " & Trim(sn(j, 3))
    Next

    For j = 1 To UBound(sn)
      If sn(j, 1) = 3 Then Sheet1.Cells(j, 3).AddComment Mid(.Item(Trim(sn(j, 3))), 2)
    Next
  End With
  
  Sheet1.Cells(1).Resize(UBound(sn), UBound(sn, 2)) = sn
End Sub

[HansV]

This should return the correct order.
The Mid(s, 3) in the previous version and Left(s, Len(s) - 2) in the new one removes the extra carriage return/line feed from the string.

Code: Select all

Sub CreateComments()
    Dim LastRow As Long, r As Long
    Dim s As String
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    For r = LastRow To 2 Step -1
        Select Case Range("A" & r).Value
            Case 3
                Range("C" & r).AddComment Mid(s, 3)
            With Range("C" & r).Comment.Shape.TextFrame
                With .Characters.Font
                    .Name = "Arial Nova Light"
                    .Size = 12
                End With
                .AutoSize = True
            End With
            s = ""
            Case 4
                s = s & vbCrLf & Range("B" & r).Value & " " & Range("C" & r).Value
        End Select
    Next r
End Sub

[gailb]

Thanks Hans for the update, but this seems like the same code as before.

Thank you snb for your additional code.

[HansV]

Sorry, my mistake.

Code: Select all

Sub CreateComments()
    Dim LastRow As Long, r As Long
    Dim s As String
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    For r = LastRow To 2 Step -1
        Select Case Range("A" & r).Value
            Case 3
                Range("C" & r).AddComment Left(s, Len(s) - 2)
            With Range("C" & r).Comment.Shape.TextFrame
                With .Characters.Font
                    .Name = "Arial Nova Light"
                    .Size = 12
                End With
                .AutoSize = True
            End With
            s = ""
            Case 4
                s = Range("B" & r).Value & " " & Range("C" & r).Value & vbCrLf & s
        End Select
    Next r
End Sub

[gailb]

Thank you Hans for all of your time. Works great.