Cuting Portion of Cell Value to Cell Comments

[excelforum123]

I have an Excel 2007 workbook with several sheets, and various cells in several of the sheets have column headers with a description in the same cell enclosed in curly brackets, e.g. Header{Description}. I would like to to keep the column headers in their respective cells, but move (cut) the descriptions along with the brackets to the respective cell comments. Any ideas on how to do this in Excel VBA?

[NickyC]

Hi
try this Macro
you will have to change set variable "rng" to the range you want to sort

Sub Macro1()
Dim rng As Range, CCell As Range, txt As String, ParseVal, CellText1 As String, CellText2 As String, CommentText As String
Set rng = Range("A1:c2") 'range of cells to search
For Each CCell In rng.Cells
    If Replace(CCell.Value, "{", "") <> CCell.Value And Replace(CCell.Value, "}", "") <> CCell.Value Then
        CellText1 = ""
        CellText2 = ""
        CommentText = ""
        ParseVal = Split(Replace(CCell.Value, "}", "{"), "{")
        CellText1 = Trim(Replace(ParseVal(0), "{", ""))
        CommentText = Trim(Replace(ParseVal(1), "{", ""))
        CellText2 = Trim(Replace(ParseVal(2), "{", ""))
        MsgBox CellText2
        If CellText2 <> "" Then CellText1 = CellText1 & ", " & CellText2
        CCell.Value = CellText1
        CCell.AddComment (CommentText)
    End If
Next CCell

End Sub

[excelforum123]

Thank you. This worked good for the active worksheet, what modifications would need to be made to work automatically for all worksheets in the workbook? Thanks again.

[NickyC]

is it the same range in every sheet? if so, try:

Sub Macro1()
Dim rng As Range, CCell As Range, txt As String, ParseVal, CellText1 As String, CellText2 As String, CommentText As String, ws, ThisSheet as string

Thissheet = activesheet.name

for each ws in activeworkbook.worksheets

Set rng = Range("A1:c2") 'range of cells to search
For Each CCell In rng.Cells
    If Replace(CCell.Value, "{", "") <> CCell.Value And Replace(CCell.Value, "}", "") <> CCell.Value Then
        CellText1 = ""
        CellText2 = ""
        CommentText = ""
        ParseVal = Split(Replace(CCell.Value, "}", "{"), "{")
        CellText1 = Trim(Replace(ParseVal(0), "{", ""))
        CommentText = Trim(Replace(ParseVal(1), "{", ""))
        CellText2 = Trim(Replace(ParseVal(2), "{", ""))
        MsgBox CellText2
        If CellText2 <> "" Then CellText1 = CellText1 & ", " & CellText2
        CCell.Value = CellText1
        CCell.AddComment (CommentText)
    End If
Next CCell
next ws
End Sub

[excelforum123]

Yes, it is for the same range, however, it still only works for the active sheet. After running it, I do get a pop-up Message Box with no message, which I click on "Ok" to dismiss.

[NickyC]

sorry, I should always check code before posting!
try this:

Sub Macro1()
Dim rng As Range, CCell As Range, txt As String, ParseVal, CellText1 As String, CellText2 As String, CommentText As String, ws, ThisSheet As String

ThisSheet = ActiveSheet.Name

For Each ws In ActiveWorkbook.Worksheets
    ws.Select

  Set rng = Range("A1:c2") 'range of cells to search
  For Each CCell In rng.Cells
    If Replace(CCell.Value, "{", "") <> CCell.Value And Replace(CCell.Value, "}", "") <> CCell.Value Then
        CellText1 = ""
        CellText2 = ""
        CommentText = ""
        ParseVal = Split(Replace(CCell.Value, "}", "{"), "{")
        CellText1 = Trim(Replace(ParseVal(0), "{", ""))
        CommentText = Trim(Replace(ParseVal(1), "{", ""))
        CellText2 = Trim(Replace(ParseVal(2), "{", ""))
        MsgBox CellText2
        If CellText2 <> "" Then CellText1 = CellText1 & ", " & CellText2
        CCell.Value = CellText1
        CCell.AddComment (CommentText)
    End If
  Next CCell
Next ws
Sheets(ThisSheet).Select
End Sub

[excelforum123]

Outstanding. Thanks for the quick assistance. It worked great.