Excel VBA：同一单元格内文本框垂直排列及行高自动调整实现

一、文本框位置错误的修复 #

你的问题核心在于：原代码查找目标单元格的文本框时，找到第一个匹配项就停止遍历，导致第三个及以后的文本框都基于第一个文本框的位置计算，最终出现重叠。

要解决这个问题，需要遍历所有文本框，记录最后一个位于目标单元格的文本框，以此为基准计算新文本框的顶部位置：

' 找到最后一个位于目标单元格的文本框（替换原遍历逻辑）
Dim lastTextbox As Shape
Set lastTextbox = Nothing ' 初始化
For Each originalTextbox In calendarSheet.Shapes
    If originalTextbox.Type = msoTextBox Then
        If originalTextbox.TopLeftCell.Row = targetRow And originalTextbox.TopLeftCell.Column = targetColumn Then
            ' 不退出循环，持续更新为当前匹配的文本框，最终得到最后一个
            Set lastTextbox = originalTextbox
        End If
    End If
Next originalTextbox

' 计算新文本框的顶部位置
Dim topPosition As Double
If Not lastTextbox Is Nothing Then
    topPosition = lastTextbox.Top + lastTextbox.Height + 1 ' 基于最后一个文本框的底部+间距
Else
    topPosition = calendarSheet.Cells(targetRow, targetColumn).Top
End If

二、自动调整行高的实现 #

每次添加完新文本框后，计算目标单元格下所有文本框的总高度（包含间距），然后设置行高适配这个总高度：

' 添加完新文本框后，计算当前单元格所有文本框的总高度
Dim totalHeight As Double
totalHeight = 0
Dim tbCheck As Shape
For Each tbCheck In calendarSheet.Shapes
    If tbCheck.Type = msoTextBox Then
        If tbCheck.TopLeftCell.Row = targetRow And tbCheck.TopLeftCell.Column = targetColumn Then
            totalHeight = totalHeight + tbCheck.Height + 1 ' 累加每个文本框高度+间距
        End If
    End If
Next tbCheck

' 调整行高（直接设置为总高度，确保容纳所有内容）
If totalHeight > 0 Then
    calendarSheet.Rows(targetRow).RowHeight = totalHeight
End If

修改后的完整代码 #

If Not searchCell Is Nothing Then
    Dim targetCell As Range
    Dim targetColumn As Long, targetRow As Long ' 补充声明targetRow
    targetRow = searchCell.Row
    targetColumn = searchCell.Column
    
    For Each targetCell In searchRange
        If IsDate(targetCell.Value) Then
            Dim currentDate As Date
            currentDate = DateValue(targetCell.Value)
            
            ' 匹配日期的日和月
            If Day(currentDate) = Day(searchDate) And Month(currentDate) = Month(searchDate) Then
                Dim lastTextbox As Shape
                Set lastTextbox = Nothing
                
                ' 遍历找到最后一个位于目标单元格的文本框
                Dim originalTextbox As Shape
                For Each originalTextbox In calendarSheet.Shapes
                    If originalTextbox.Type = msoTextBox Then
                        If originalTextbox.TopLeftCell.Row = targetRow And originalTextbox.TopLeftCell.Column = targetColumn Then
                            Set lastTextbox = originalTextbox
                        End If
                    End If
                Next originalTextbox
                                
                ' 计算新文本框的顶部位置
                Dim topPosition As Double
                If Not lastTextbox Is Nothing Then
                    topPosition = lastTextbox.Top + lastTextbox.Height + 1 ' 加1个单位间距
                Else
                    topPosition = calendarSheet.Cells(targetRow, targetColumn).Top
                End If
                
                Dim tb As Shape
                Set tb = calendarSheet.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
                  Left:=calendarSheet.Cells(targetCell.Row, targetCell.Column).Left, _
                  Top:=topPosition, _
                  Width:=calendarSheet.Cells(targetCell.Row, targetCell.Column).Width, _
                  Height:=80)

                ' 设置文本框属性
                tb.Fill.Transparency = 1
                tb.Line.Visible = msoFalse
                tb.TextFrame2.TextRange.Text = SVDateValue & vbCrLf & DPValue & vbCrLf & companyValue & vbCrLf & SVTimeValue
                tb.TextFrame2.TextRange.Characters(1, Len(SVDateValue)).Font.Fill.Visible = msoFalse
                
                ' --- 新增：自动调整行高 ---
                Dim totalHeight As Double
                totalHeight = 0
                Dim tbCheck As Shape
                For Each tbCheck In calendarSheet.Shapes
                    If tbCheck.Type = msoTextBox Then
                        If tbCheck.TopLeftCell.Row = targetRow And tbCheck.TopLeftCell.Column = targetColumn Then
                            totalHeight = totalHeight + tbCheck.Height + 1
                        End If
                    End If
                Next tbCheck
                ' 设置行高，确保容纳所有文本框
                If totalHeight > 0 Then
                    calendarSheet.Rows(targetRow).RowHeight = totalHeight
                End If
            End If
        End If
    Next targetCell
    
Else
    MsgBox "指定范围内未找到该日期。", vbExclamation
End If

关键说明 #

1. 文本框位置：通过遍历所有匹配的文本框，保留最后一个的引用，确保新文本框始终在最下方的文本框之后创建。
2. 行高调整：每次添加后重新计算该单元格下所有文本框的总高度，直接设置行高为总高度，避免内容被截断。

内容的提问来源于stack exchange，提问作者Kingly Lee