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