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

Question

我正在 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 个文本框，就会发生这种情况

Answer 1

并没有真正回答你的根本问题，但这里有一个重新设计你的日历的建议......

在日历表代码模块中：

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

我的工作表设置如下：

没有用于添加/编辑事件的代码，但现在数据都在表中，这就简单多了...