对excel表格中达到409磅仍无法完全显示的单元格自动插入一列并合并单元格

在清单排版时出现的问题，因为有众多单元格已经超出409磅行高限制，需要合并单元格才能突破限制，故而制作了该代码，该代码作用域为选定区域，优先先自适应行高，当达到最大磅数时则合并单元格突破限制。但因为excel底层太过老旧，无法判断单元格内容是否超出，只能手动调整。。。。将就用吧

Sub 突破行高限制合并单元格()
    Dim ws As Worksheet
    Set ws = ActiveSheet ' 当前工作表

    ' 获取当前选中的所有单元格
    Dim sel As Range
    Set sel = Selection
    If sel Is Nothing Then Exit Sub
    
    ' 将选区内单元格设置为自动换行（WrapText），使Excel自动换行并调整行高​:contentReference[oaicite:9]{index=9}
    sel.WrapText = True
    
    ' 收集选中单元格所在的所有不重复行号
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    Dim c As Range
    For Each c In sel.Cells
        If Not dict.Exists(c.Row) Then
            dict.Add c.Row, c.Row
        End If
    Next c
    
    ' 将行号键转换为数组并按从大到小排序（避免插入行时影响后续行的索引）
    Dim rowArr As Variant
    rowArr = dict.Keys
    Dim i As Long, j As Long, temp As Long
    For i = LBound(rowArr) To UBound(rowArr) - 1
        For j = i + 1 To UBound(rowArr)
            If rowArr(i) < rowArr(j) Then
                temp = rowArr(i)
                rowArr(i) = rowArr(j)
                rowArr(j) = temp
            End If
        Next j
    Next i
    
    ' 逐行处理（从最大行号开始）
    Dim rowIndex As Long
    For i = LBound(rowArr) To UBound(rowArr)
        rowIndex = rowArr(i)
        With ws.Rows(rowIndex)
        End With
        
        ' 如果此行自动调整后的高度达到最大值409，则需要插入并合并
        If ws.Rows(rowIndex).RowHeight >= 409 Then ' Excel行高最大限制409磅&#8203;:contentReference[oaicite:11]{index=11}
            ' 在该行下方插入新行&#8203;:contentReference[oaicite:12]{index=12}
            ws.Rows(rowIndex + 1).Insert Shift:=xlShiftDown
            
            ' 对选中区域中属于此行的每个单元格执行合并
            For Each c In sel.Cells
                If c.Row = rowIndex Then
                    ' 获取原单元格和新行对应列的单元格
                    Dim origCell As Range
                    Dim newCell As Range
                    Set origCell = ws.Cells(rowIndex, c.Column)
                    Set newCell = ws.Cells(rowIndex + 1, c.Column)
                    
                    ' 复制格式：将原单元格的格式粘贴到新行单元格
                    origCell.Copy
                    newCell.PasteSpecial Paste:=xlPasteFormats
                    Application.CutCopyMode = False
                    
                    ' 合并单元格（纵向合并）并保持原格式
                    ws.Range(origCell, newCell).Merge
                    ' 合并后确保自动换行
                    origCell.WrapText = True
                End If
            Next
            
            ' 合并后调整行高：将两行行高设置为最大值以尽量显示更多内容&#8203;:contentReference[oaicite:13]{index=13}
            ws.Rows(rowIndex).RowHeight = 409
            ws.Rows(rowIndex + 1).RowHeight = 409
        End If
    Next i
End Sub