将文本框位置锁定为更新时相同

问：

我正在 Excel 中创建一个日历功能，该功能从表单中获取输入，并基于此将工作详细信息放入动态日历中。我现在面临的问题是，每当我更新文本框位置时，如果同一单元格中还有另一个文本框，它都会重新定位到另一个位置，我相信这是我在代码中具有的公式的原因，但这是为了创建文本框，就像基于以前的文本框一样，它工作正常。

例如：如果我在第一个文本框创建后更新第一个文本框中的一些值，第二个文本框就在它正下方并有一些间距，第一个文本框将重新定位到第二个文本框的位置。

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 '

我尝试过使用 ChatGPT，但我无法真正解决这个问题，就像从故障排除中我知道这部分代码并没有真正起作用，因为 datefromshape 将遍历历中的所有文本框，而不是我正在编辑的文本框，但我对它应该是什么一无所知，因为它无法提取正确的值，因为像 dpvaluesfromshape 可能就像第一个文本框 DP11 但 dpnumber是 DP3，但那是因为它正在遍历所有文本框，所以稍后也有 DP3。我也尝试过锁定单元格，但它不起作用。有人可以为我提供这个问题的解决方案并告诉我什么是工作代码。我真的非常感谢。我已经被困了几个星期，现在我快到最后期限了。请帮忙！先谢谢你。

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 '

这是我成功创建作业后的样子[在日历
中创建作业后，如果我更新文本框 1 或 2，而该单元格中有 3 个文本框，这将发生这种情况