Beginner help with VBA

[ttffxxz1]

As a preface, I'm totally new to VBA and have been trying to use ChatGPT to help me get started.

I have a simple request. I'm trying to assign a macro to a button in Column I which collapses and expands the text in Column H.

The cell is a timeline of events formatted like this:

01/01 - this is update 1
02/01 - this is update 2
this is also part of update 2

etc

When I click on the button to collapse the cell, I want it to only show the most recent event - the text following the date in bold regardless of how many lines of text there are. Then when I click the button again I want the cell to expand and show the full timeline of events.

I was initially given this code by ChatGPT:

Sub ExpandCell()
    Dim Button As Shape
    Set Button = ActiveSheet.Shapes(Application.Caller)
    Dim Cell As Range
    Set Cell = Button.TopLeftCell.Offset(0, -1)

    ' Check if cell is expanded or collapsed
    If Cell.EntireRow.RowHeight = 15 Then
        Cell.EntireRow.AutoFit
    Else
        Cell.EntireRow.RowHeight = 15
    End If
End Sub

The problem with this is it collapsed the cell to only the final line of text, which cuts off updates which cover multiple lines of text. So, I asked it to create me another version which collapsed the text to show everything after the date in bold. It gave me this:

Sub ExpandCell()
    Dim Button As Shape
    Set Button = ActiveSheet.Shapes(Application.Caller)
    Dim Cell As Range
    Set Cell = Button.TopLeftCell.Offset(0, -1)
Dim Text As String
    Text = Cell.Value
    Dim Lines() As String
    Lines = Split(Text, Chr(10))
' Loop through the lines to find the bold text (indicating the start of the latest update)
    Dim i As Integer
    For i = UBound(Lines) To 0 Step -1
        If Lines(i) Like "[0-9]/[0-9]:*" Then
            Exit For
        End If
    Next i
' Set the height of the cell based on the location of the latest update
    If i = UBound(Lines) Then
        Cell.EntireRow.AutoFit
    Else
        Cell.EntireRow.RowHeight = Button.TopLeftCell.RowHeight
    End If
End Sub

The problem I have now, is that the button doesn't work at all. When I click 'debug' it highlights this in yellow.

Set Button = ActiveSheet.Shapes(Application.Caller)

I don't understand why that part of the code is now problematic, when it was working fine in the previous code? I've tried all the obvious solutions of closing and restarting excel, ensuring its a shape that can be assigned a macro etc.

Please advise?

[p45cal]

Could you attach a woorkbook with the relevant sheet and the code as you have it? It's hard work to try and guess and reproduce (wrongly probably) your setup.

ChatGPT is often very poor:
Like "[0-9]/[0-9]:*" will be OK for the likes of 4/9: but will go wrong with 04/6: or 4/06: or 04/06:

Cell.EntireRow.RowHeight = Button.TopLeftCell.RowHeight

is just silly.
It might need to be something more like:

Cell.EntireRow.RowHeight = 15*(ubound(lines)-i)

but it will be highly dependent on there being the correct font size in the cell, the cell being formatted correctly and probably more.

[georgiboy]

I had been playing with this, I came up with the below (although longer than I thought it would be)

Update:
I created a button to show latest only and one to put it back as it was.

Code for latest only:

Sub test()
    Dim var As Variant, x As Long, z As Long, n As Long
    Dim oVar() As Variant, rCell As Range
    Dim tRng As Range
    
    Set tRng = Range("A2:A5") ' change your range here
    
    For Each rCell In tRng
        var = Split(rCell, Chr(10))
        ' manipulate array
        For x = 0 To UBound(var)
            If Not Mid(var(x), 3, 1) = "/" Then
                var(z) = var(z) & vbNewLine & var(x)
                var(x) = ""
            Else
                z = x
            End If
        Next x
        'reverse the array
        For x = UBound(var) To 0 Step -1
            If var(x) <> "" And var(x) <> Chr(10) Then
                ReDim Preserve oVar(n)
                oVar(n) = var(x)
                n = n + 1
            End If
        Next x
        'output the result
        rCell = Join(oVar, vbNewLine)
        rCell.RowHeight = (UBound(Split(oVar(0), vbNewLine)) + 1) * 15
        Erase oVar
        n = 0
    Next rCell
End Sub

Code to put it back as it was:

Sub UndoTest()
    Dim tRng As Range, var As Variant, rCell As Range
    Dim oVar() As Variant, z As Long, x As Long
    Dim n As Long
    
    Set tRng = Range("A2:A5") ' change your range here
    
    For Each rCell In tRng
        var = Split(rCell, vbNewLine)
        ' manipulate array
        For x = 0 To UBound(var)
            If Not Mid(var(x), 3, 1) = "/" Then
                var(z) = var(z) & vbNewLine & var(x)
                var(x) = ""
            Else
                z = x
            End If
        Next x
        'reverse the array
        For x = UBound(var) To 0 Step -1
            If var(x) <> "" And var(x) <> Chr(10) Then
                ReDim Preserve oVar(n)
                oVar(n) = var(x)
                n = n + 1
            End If
        Next x
        rCell = Join(oVar, vbNewLine)
        Erase oVar
        n = 0
    Next rCell
    tRng.EntireRow.AutoFit
End Sub