Форум программистов [Powered by Invision Power Board]

Код


Private Sub Workbook_Open()
    FixAutoFit
End Sub

Private Function FixAutoFit()
    Dim ws As Worksheet
    Dim cell As Range
    
    Application.ScreenUpdating = False
    
    For Each ws In Worksheets
        For Each cell In ws.UsedRange
            If cell.Rows.Count = 1 Then
                If cell.MergeCells And cell.WrapText And IsTopLeftCell(cell) Then
                    FixAutoFitForCell (cell)
                End If
            Else
                MsgBox ("Not Supported:" + cell.Address)
            End If
        Next cell
    Next ws
End Function

Private Function FixAutoFitForCell(cell As Range)
    Dim totalWidth As Single
    Dim oldHeight As Single
    Dim oldWidth As Single
    Dim cellCount As Integer
    Dim ac As Range
    
    cellCount = cell.MergeArea.Columns.Count
    
    For Each ac In cell.MergeArea.Cells
        totalWidth = totalWidth + ac.Width
    Next ac
    
    cell.WrapText = False
    cell.MergeArea.UnMerge
    oldWidth = cell.Width
    cell.Width = totalWidth
    cell.WrapText = True
    cell.Row.AutoFit

    If cell.Height < oldHeight Then
        cell.Height = oldHeight
    End If
    
    cell.Width = oldWidth
End Function

Private Function IsTopLeftCell(cell As Range)
    If cell.Address = cell.MergeArea.Cells(1, 1).Address Then
        IsTopLeftCell = True
    Else
        IsTopLeftCell = False
    End If
End Function

Код


Private Sub Workbook_Open()
    FixAutoFit
End Sub

Private Function FixAutoFit()
    Dim ws As Worksheet
    Dim cell As Range
    
    Application.ScreenUpdating = False
    
    For Each ws In Worksheets
        For Each cell In ws.UsedRange.Cells
            If cell.Rows.Count = 1 Then
                If cell.MergeCells And cell.WrapText And IsTopLeftCell(cell) Then
                    FixAutoFitForCell (cell)
                End If
            Else
                MsgBox ("Not Supported:" + cell.Address)
            End If
        Next cell
    Next ws
End Function

Private Function FixAutoFitForCell(cell As Range)
'    Dim totalWidth As Single
'    Dim oldHeight As Single
'    Dim oldWidth As Single
'    Dim cellCount As Integer
'    Dim ac As Range
    
'    cellCount = cell.MergeArea.Columns.Count
    
'    For Each ac In cell.MergeArea.Cells
'        totalWidth = totalWidth + ac.Width
'    Next ac
    
'    cell.WrapText = False
'    cell.MergeArea.UnMerge
'    oldWidth = cell.Width
'    cell.Width = totalWidth
'    cell.WrapText = True
'    cell.Row.AutoFit

'    If cell.Height < oldHeight Then
'        cell.Height = oldHeight
'    End If
    
'    cell.Width = oldWidth
End Function

Private Function IsTopLeftCell(cell As Range)
    If cell.Address = cell.MergeArea.Cells(1, 1).Address Then
        IsTopLeftCell = True
    Else
        IsTopLeftCell = False
    End If
End Function

Код


Private Function IsTopLeftCell(cell As Range)