I am creating an calendar features which takes inputs from a form and based of that I will assign into a dynamic calendar. The problem I'm facing now is that when I update my form the first textbox position does not remain at its original position but goes to the second textbox position.
I tried using ChatGPT for helped but I can't seem to find a way to solve this problem.
Dim SVDateValue As String
Dim DPValue As String
Dim SVTimeValue As String
Dim companyValue As String
SVDateValue = sourceSheet.Range("C23").Value
DPValue = sourceSheet.Range("J12").Value
SVTimeValue = sourceSheet.Range("C24").Value
companyValue = sourceSheet.Range("C11").Value & " " & sourceSheet.Range("C12").Value
'Open the DynamicCalendar workbook
Dim calendarWorkbook As Workbook
Set calendarWorkbook = Workbooks.Open("C:\Users\Samuel\Desktop\DynamicCalendar.xlsm")
'Get the Values worksheet from the DynamicCalendar workbook
Dim destSheet As Worksheet
Set destSheet = calendarWorkbook.Sheets("Values")
If destSheet.ProtectContents Then
destSheet.Unprotect
End If
' 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
'MsgBox extractedMonth
'MsgBox extractedYear
'MsgBox extractedDay
'MsgBox extractedDay
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)
'MsgBox formattedDay 'Formated Date so it is dd
' Delete Existing
Dim shapesToDelete As New Collection ' Collection to hold shapes to be deleted
'MsgBox dpNumber
For Each TextBox In calendarSheet.Shapes
If TextBox.Type = msoTextBox Then ' Check if the shape is a textbox
Dim lines() As String
Dim dpValueFromShape As String
Dim dateFromShape As Date 'Additional
' Remove error handling for debugging purposes
' On Error Resume Next
lines = Split(TextBox.TextFrame.Characters.Text, vbLf) ' Split the text into lines using vbLf
' On Error GoTo 0
If UBound(lines) >= 1 Then ' Ensure there are at least 2 lines (0-based index)
dpValueFromShape = Trim(lines(1)) ' Second line (index 1) is DPValue, with leading/trailing spaces removed
dateFromShape = DateValue(lines(0)) ' First line (index 0) is the date
' Display the extracted value for debugging
'MsgBox "Extracted DP Value: " & dpValueFromShape
If dpValueFromShape = dpNumber Then
shapesToDelete.Add TextBox ' Add the shape to the collection for deletion
End If
End If
End If
Next TextBox
' Delete shapes from the collection
Dim shapeToDelete As Variant
For Each shapeToDelete In shapesToDelete
shapeToDelete.Delete
Next shapeToDelete
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
But like sometimes when I update the form for the second and third textbox or subsequent the position is alright but this is not consistent. And the original textbox one when I update it always messes up by going into the second textbox position and not the top position of that cell+spacing.
