Locking the Textbox Position To Be the Same While Update

Question

I am creating a calendar feature in Excel that takes inputs from a form and based on that I will put the job details into the dynamic calendar. The problem I'm facing now is that whenever I'm updating a textbox position, it will re-position to another position if there is another textbox in the same cell which I believe is the cause of the formula I have in the code but that is meant for creating the textbox below each other like based of previous textbox which is working fine.

For example : If I update some values in the first textbox after it was created nicely with second textbox just directly below it with some spacing,the first textbox will re-position into the second textbox position.

Transfer data to destination workbook
destSheet.Range("B1").Value = SVDateValue  ' Example: Service Date
destSheet.Range("B2").Value = DPValue
destSheet.Range("B3").Value = companyValue
destSheet.Range("B4").Value = SVTimeValue

Convert SVDateValue to a proper date value
Dim searchDate As Date
searchDate = DateValue(SVDateValue)

' Extract month, year, and day
Dim extractedMonth As String
Dim extractedYear As Integer
Dim extractedDay As Integer
Dim formattedDay As String

extractedMonth = MonthName(Month(searchDate))
extractedYear = Year(searchDate)
extractedDay = Day(searchDate)
'formattedDay = Format(extractedDay, "dd")
formattedDay = Right("0" & extractedDay, 2) ' Format as two-digit day with leading zero

Dim calendarSheet As Worksheet
Set calendarSheet = calendarWorkbook.Sheets("Calendar")

' Update the month and year cells
calendarSheet.Range("D1").Value = extractedMonth
calendarSheet.Range("G1").Value = extractedYear

' Search for the specific date within the range B:H
Dim searchRange As Range
Dim searchCell As Range
Set searchRange = calendarSheet.Range("B:H")
Set searchCell = searchRange.Find(What:=formattedDay, LookIn:=xlValues, LookAt:=xlWhole)

If Not searchCell Is Nothing Then
Dim targetCell As Range
For Each targetCell In searchRange
    If IsDate(targetCell.Value) Then
        Dim currentDate As Date
        currentDate = DateValue(targetCell.Value)

        ' Compare currentDate with SVDateValue (day and month)
        If Day(currentDate) = Day(searchDate) And Month(currentDate) = Month(searchDate) Then
            ' Set the targetRow and targetColumn based on the current targetCell
            Dim targetRow As Long
            Dim targetColumn As Long
            targetRow = targetCell.Row
            targetColumn = targetCell.Column

            ' Find the existing textbox in the same cell with matching DPValue and SVDateValue
            Dim existingTb As Shape
            For Each existingTb In calendarSheet.Shapes
                If existingTb.Type = msoTextBox Then
                    'Dim lines() As String
                    lines = Split(existingTb.TextFrame2.TextRange.Text, vbCrLf)
                    If UBound(lines) >= 1 Then
                        'Dim dpValueFromShape As String
                        dpValueFromShape = Trim(lines(1)) ' Second line (index 1) is DPValue
                        'Dim dateFromShape As Date
                        dateFromShape = DateValue(lines(0)) ' First line (index 0) is the date
                        If dpValueFromShape = dpNumber And dateFromShape = SVDateValue Then
                            ' Update the text content of the existing textbox
                            existingTb.TextFrame2.TextRange.Text = SVDateValue & vbCrLf & DPValue & vbCrLf & companyValue & vbCrLf & SVTimeValue
                            ' Optionally, update other properties if needed
                            Exit For
                        End If
                    End If
                End If
            Next existingTb

            ' If no existing textbox found, create a new one in the correct cell
            If existingTb Is Nothing Then
                ' Calculate the top position for the new textbox (below the existing ones)
                Dim spacing As Double
                spacing = 10 ' Adjust spacing as needed
                Dim originalTextboxHeight As Double
                originalTextboxHeight = 90 ' Fixed height for the original textbox

                ' Count the number of textboxes in the same cell
                Dim textBoxCount As Long
                For Each tb In calendarSheet.Shapes
                    If tb.Type = msoTextBox Then
                        If tb.TopLeftCell.Row = targetRow And tb.TopLeftCell.Column = targetColumn Then
                            textBoxCount = textBoxCount + 1
                        End If
                    End If
                Next tb

                ' Calculate the top position using the formula: targetCell.Top + TextBox.Height * n + spacing
                Dim topPosition As Double
                topPosition = calendarSheet.Cells(targetRow, targetColumn).Top + spacing ' Start from the top of the cell

                Dim tbTopPosition As Double
                tbTopPosition = topPosition + originalTextboxHeight * textBoxCount + spacing

                ' Create a new textbox in the correct cell and position
                Set tb = calendarSheet.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
                                                          Left:=calendarSheet.Cells(targetRow, targetColumn).Left, _
                                                          Top:=tbTopPosition, _
                                                          Width:=calendarSheet.Cells(targetRow, targetColumn).Width, _
                                                          Height:=80)
                ' ... Set properties for the TextBox
                tb.Fill.Transparency = 1 ' Fully transparent fill
                tb.Line.Visible = msoFalse ' No border

                ' Set TextBox text to SVDate and company values
                tb.TextFrame2.TextRange.Text = SVDateValue & vbCrLf & DPValue & vbCrLf & companyValue & vbCrLf & SVTimeValue

                ' Change color of SVDateValue text to not filled
                tb.TextFrame2.TextRange.Characters(1, Len(SVDateValue)).Font.Fill.Visible = msoFalse

                ' Increment the textbox count
                textBoxCount = textBoxCount + 1
            End If
        End If
    End If
Next targetCell 
Else
MsgBox "Date not found in the specified range.", vbExclamation
End If
' Close the workbook and save changes
calendarWorkbook.Save
'calendarWorkbook.Close
'calendarWorkbook.Close SaveChanges:=True
End If
End Sub '

I have tried using ChatGPT but I cant really solve this, Like from troubleshooting i know that this part of the code is not really working cause the datefromshape will go through all the textbox in my calendar not the one I'm editing but that I am clueless on what it should be cause like it can't extract the right values since like dpvaluesfromshape would maybe be like the first textbox DP11 but the dpnumber is DP3 but that is cause it is going through all the textbox so there is DP3 later on also. I have also tried locking the cell but it doesn't work . Can someone provide me a solution to this problem and show me what is the working code . I would really appreciate it very much. I have been stuck for weeks and its my close to deadline. PLEASE HELP! Thank you in advance.

Dim existingTb As Shape
        For Each existingTb In calendarSheet.Shapes
            If existingTb.Type = msoTextBox Then
                'Dim lines() As String
                lines = Split(existingTb.TextFrame2.TextRange.Text, vbCrLf)
                If UBound(lines) >= 1 Then
                    'Dim dpValueFromShape As String
                    dpValueFromShape = Trim(lines(1)) ' Second line (index 1) is DPValue
                    'Dim dateFromShape As Date
                    dateFromShape = DateValue(lines(0)) ' First line (index 0) is the date
                    If dpValueFromShape = dpNumber And dateFromShape = SVDateValue Then
                        ' Update the text content of the existing textbox
                        existingTb.TextFrame2.TextRange.Text = SVDateValue & vbCrLf & DPValue & vbCrLf & companyValue & vbCrLf & SVTimeValue
                        ' Optionally, update other properties if needed
                        Exit For
                    End If
                End If
            End If
        Next existingTb '

This is what it look like after I successfully created the jobs[After Creating the Jobs in the CALENDAR
This is what will happen if I update textbox 1 or 2 while there is 3 textbox in that cell

Why not write the information directly into the cell? Seems like that would be much easier to manage... — Tim Williams, Aug 15 '23 at 17:05
Because it is a dynamic calendar in one sheet and in that cell there is a formula calculating it which shows the date — Kingly Lee, Aug 15 '23 at 17:57
Isn't managing textboxes in the cell trickier than managing the cell content though? — Tim Williams, Aug 15 '23 at 18:03
Like i said in that cell im using a formula to make my dynamic calendar dates, and i cant concatenate it behind bro . Read my question which is why i have change my approach — Kingly Lee, Aug 16 '23 at 06:19
The first thing you do in your code is set the month and year for the calendar, which presumably updates all the dates on the sheet. In that case won't any *existing* textboxes need to be removed ? If for example they were for a previous month. You code under "Find the existing textbox in the same cell with matching DPValue and SVDateValue" doesn't check the location of any textbox it finds. Also not seeing any dates in the textboxes in your screenshots. — Tim Williams, Aug 16 '23 at 15:32
That is just setting the month and year in the calendar, In my Calendar Workbook, I have hide textboxes not in that month. I need a solution for my problem ... — Kingly Lee, Aug 16 '23 at 16:05
If editing an *existing* textbox, I don't see anything in your code which would cause it to move to a different location. You only add a new textbox, or update the content of an existing one. Even if your code failed to find the existing (eg) "Company A" textbox and accidentally added another one, that wouldn't cause the existing one to move... — Tim Williams, Aug 16 '23 at 21:43
Like i said above,my update content is not working and it is somehow adding a new textbox when i update so it uses that formula... — Kingly Lee, Aug 17 '23 at 04:49
Looks like it didn't add a new one - it just moved the "DP1" textbox to the same position as "DP3"? — Tim Williams, Aug 17 '23 at 05:19
The difficulty here is there's too much setup for anyone to be able to test your code and reproduce the problem. There are no obvious (to me) problems in the code, so it's difficult to make any suggestions. — Tim Williams, Aug 17 '23 at 17:11

score 0 · Answer 1 · answered Aug 18 '23 at 21:22

Not really answering your root problem, but here's a suggestion to re-work your calendar...

In the Calendar sheet code module:

Option Explicit

'for testing...
Sub testSetMonth()
    Me.SetMonth 2023, 8
End Sub

'update if the year or month are changed
Private Sub Worksheet_Change(ByVal Target As range)
    Dim rng As range
    Set rng = Application.Intersect(Target, Me.range("D2:D3"))
    If Not rng Is Nothing Then UpdateMonth
End Sub

'for calling from elsewhere - set the year+month
Public Sub SetMonth(yr As Long, mon As Long)
    Dim t
    t = Timer
    Application.EnableEvents = False 'suspend events
    Me.CurrentYear = yr
    Me.CurrentMonth = mon
    Application.EnableEvents = True
    Debug.Print Timer - t
    UpdateMonth 'Trigger update
End Sub

'reset the calendar to the selected yr/mon and populate with any
'  events listed in the table
Sub UpdateMonth()
    Dim rngCal As range, mon As Long, rngEvents As range, m, t
    Dim dt As Date, c As range, dayNum As Long, n As Long, i As Long
    Application.ScreenUpdating = False
    t = Timer
    Set rngCal = Me.range("B6:H11")
    rngCal.ClearContents
    rngCal.Font.Color = vbBlack
    rngCal.Font.Bold = False
    mon = CurrentMonth
    dt = DateSerial(CurrentYear, mon, 1)
    n = Weekday(dt)
    i = 1
    SortEvents
    Set rngEvents = EventData
    
    Do While Month(dt) = mon
        With rngCal.Cells(n)
            AddCellText .Cells(1), i, 12, vbBlue, True
            m = Application.Match(CLng(dt), rngEvents.Columns(1), 0)
            If Not IsError(m) Then
                Set c = rngEvents.Columns(1).Cells(m)
                Do While c.Value = dt
                    AddCellText .Cells(1), c.Offset(0, 2), 8, vbRed, True
                    AddCellText .Cells(1), c.Offset(0, 3) & _
                             " (" & Format(c.Offset(0, 1), "h:mm") & ")", 8, vbBlack, False
                    Set c = c.Offset(1)
                Loop
            End If
        End With
        n = n + 1
        i = i + 1
        dt = dt + 1
    Loop
    Debug.Print "Done", Timer - t
End Sub

'add a line of text to a cell and format the added text
Sub AddCellText(c As range, ByVal txt, sz As Long, clr As Long, isBold As Boolean)
    Dim v As String, sep As String
    v = c.Value
    txt = IIf(Len(v) > 0, vbLf, "") & txt
    With c.Characters(Len(v) + 1, Len(txt))
        .Text = txt
        .Font.Size = sz
        .Font.Color = clr
        .Font.Bold = isBold
    End With
End Sub

'Year/month properties
Property Let CurrentYear(yr As Long)
    Me.range("D2").Value = yr
End Property
Property Get CurrentYear() As Long
    CurrentYear = Me.range("D2").Value
End Property
Property Let CurrentMonth(mon As Long)
    Me.range("D3").Value = mon
End Property
Property Get CurrentMonth() As Long
    CurrentMonth = Me.range("D3").Value
End Property

'sort event data by date/time
Sub SortEvents()
    Dim rngSort As range
    Set rngSort = EventData
    With Me.Sort.SortFields
        .Clear
        .Add2 key:=rngSort.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending
        .Add2 key:=rngSort.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending
    End With
    With Me.Sort
        .SetRange rngSort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Me.range("A1").Select
End Sub

'range with all event data
Property Get EventData() As range
    Set EventData = Me.range("B17:E" & Me.Cells(Rows.Count, "B").End(xlUp).Row)
End Property

My sheet was set up like this:

No code there for adding/editing events, but that's much simpler now the data is all in a table...

Locking the Textbox Position To Be the Same While Update

1 Answers1