Autofit Comment Box Height when specifying the Width or Autofit the Width when specifying the Height

[OilEconomist]

Hello and Happy New Year! Thanks in advance with any assistance.

My objective is to have a Macro Function that automatically sizes a comment text box if I specify the width or height. Basically, if I specify the height, I would like the function to figure out the height in order for it to fit all the text in the comment box. The following is what I have written for now.

Please note, I have searched all over the internet and gone to several forums and coded the following. I have sample subs for each. At times it is not autofitting when I specify either the height or width. It's either too small or too large.

Option Explicit

Sub SetCommentsPropertiesWidth()
    
    
    
    '_________________________________________________________________________________________________
    'Turn on alerts, screen UDs, and automatic calculation
        
        Application.DisplayAlerts = True 'Turn on Display Alerts
        Application.ScreenUpdating = True ''Turn on Screen UD
        Application.Calculation = xlManual ''Turn on Automatic Calculations
    
    
    
    '___________________________________________________________________________________________________
    'Dimensioning
        
        Dim CmtHeight As Long, CmtWidth As Long
        
        Dim ShtNm As String
        
        Dim Rng As Range
        
        
        
    '___________________________________________________________________________________________________
    'Settings
        
        ShtNm = ActiveSheet.Name
        
        CmtWidth = 0
        
        CmtHeight = 30
    
    
    
    '___________________________________________________________________________________________________
    'Code
        
        With Sheets(ShtNm)
            .Rows.EntireRow.Hidden = False
            .Columns.EntireColumn.Hidden = False
            .Outline.ShowLevels RowLevels:=8, ColumnLevels:=8
        End With
    
    
    
    '___________________________________________________________________________________________________
    'Code
        
        With Sheets(ShtNm)
        
            'Set the Range of Comments
             Set Rng = .Range(.Cells(8, 3), .Cells(8, 32))
        
            'Function SetCommentPropertiesF(ShtNm As String, Rng As Range, _
                               CmtHeight As Long, CmtWidth As Long) As Variant
             SetCommentPropertiesF ShtNm, Rng, CmtHeight, CmtWidth
            
        End With



    '_________________________________________________________________________________________________
    'Code - Calculate
        
        With Sheets(ShtNm)
            .Calculate
        End With

    '___________________________________________________________________________________________________
    'Code
        
        With Sheets(ShtNm)
            .Rows.EntireRow.Hidden = False
            .Columns.EntireColumn.Hidden = False
            .Outline.ShowLevels RowLevels:=1, ColumnLevels:=1
        End With
        
        

    '_________________________________________________________________________________________________
    'Turn on alerts, screen UDs, and automatic calculation
    
        Application.DisplayAlerts = True 'Turn on Display Alerts
        Application.ScreenUpdating = True ''Turn on Screen UD
        Application.Calculation = xlCalculationAutomatic ''Turn on Automatic Calculations



    '___________________________________________________________________________________________________
    'End Sub
    
    
     

End Sub




Sub SetCommentsPropertiesHeight()
    
    
    
    '_________________________________________________________________________________________________
    'Turn on alerts, screen UDs, and automatic calculation
        
        Application.DisplayAlerts = True 'Turn on Display Alerts
        Application.ScreenUpdating = True ''Turn on Screen UD
        Application.Calculation = xlManual ''Turn on Automatic Calculations
    
    
    
    '___________________________________________________________________________________________________
    'Dimensioning
        
        Dim CmtHeight As Long, CmtWidth As Long
        
        Dim ShtNm As String
        
        Dim Rng As Range
        
        
        
    '___________________________________________________________________________________________________
    'Settings
        
        ShtNm = ActiveSheet.Name
        
        CmtWidth = 225
        
        CmtHeight = 0
    
    
    
    '___________________________________________________________________________________________________
    'Code
        
        With Sheets(ShtNm)
            .Rows.EntireRow.Hidden = False
            .Columns.EntireColumn.Hidden = False
            .Outline.ShowLevels RowLevels:=8, ColumnLevels:=8
        End With
    
    
    
    '___________________________________________________________________________________________________
    'Code
        
        With Sheets(ShtNm)
        
            'Set the Range of Comments
             Set Rng = .Range(.Cells(8, 3), .Cells(8, 32))
        
            'Function SetCommentPropertiesF(ShtNm As String, Rng As Range, _
                               CmtHeight As Long, CmtWidth As Long) As Variant
             SetCommentPropertiesF ShtNm, Rng, CmtHeight, CmtWidth
            
        End With



    '_________________________________________________________________________________________________
    'Code - Calculate
        
        With Sheets(ShtNm)
            .Calculate
        End With


    '___________________________________________________________________________________________________
    'Code
        
        With Sheets(ShtNm)
            .Rows.EntireRow.Hidden = False
            .Columns.EntireColumn.Hidden = False
            .Outline.ShowLevels RowLevels:=1, ColumnLevels:=1
        End With
        

    '_________________________________________________________________________________________________
    'Turn on alerts, screen UDs, and automatic calculation
    
        Application.DisplayAlerts = True 'Turn on Display Alerts
        Application.ScreenUpdating = True ''Turn on Screen UD
        Application.Calculation = xlCalculationAutomatic ''Turn on Automatic Calculations



    '___________________________________________________________________________________________________
    'End Sub
    
    
     

End Sub



'******************************************************************************************************
Function SetCommentPropertiesF(ShtNm As String, Rng As Range, _
                               CmtHeight As Long, CmtWidth As Long) As Variant
    
    
    
    '___________________________________________________________________________________________________
    'Dimensioning
        
        'Dim Longs
         Dim Current_Length As Long
        
        'Dim Strings
         Dim aCell As Range

               

    '___________________________________________________________________________________________________
    'Code - Expand all rows an columns and make sure no row and are columns are hidden
        
                
        With Sheets(ShtNm)
            .Rows.EntireRow.Hidden = False
            .Columns.EntireColumn.Hidden = False
            .Outline.ShowLevels RowLevels:=8, ColumnLevels:=8
        End With

    
    
    
    '___________________________________________________________________________________________________
    'Code
    
        With Sheets(ShtNm)
        
            For Each aCell In Rng
                If Not aCell.Comment Is Nothing Then
                
                    With aCell.Comment.Shape.TextFrame.Characters.Font
                        .Size = 11
                        .Name = "Calibri"
                        .Bold = False
                    End With
                    
                    With aCell.Comment.Shape.TextFrame
                        .Characters(1, 31).Font.Bold = True
                    End With
                
                    With aCell.Comment.Shape
                        .TextFrame.AutoSize = True
                        If CmtHeight = 0 Then
                            Current_Length = .Width
                            .Width = CmtWidth
                            .Height = Application.Max(.Height * (Current_Length / CmtWidth), 12)
                        ElseIf CmtWidth = 0 Then
                            Current_Length = .Height
                            .Height = CmtHeight
                            .Width = Application.Max(.Width * (Current_Length / CmtHeight), 12)
                        End If
                    End With
                
                End If
            Next aCell
        
        End With



    '___________________________________________________________________________________________________
    'Code - Collapse all rows an columns and make sure no row and are columns are hidden
        
                
        With Sheets(ShtNm)
            .Rows.EntireRow.Hidden = False
            .Columns.EntireColumn.Hidden = False
            .Outline.ShowLevels RowLevels:=1, ColumnLevels:=1
        End With
        
 

    '___________________________________________________________________________________________________
    'End Function - Function SetCommentPropertiesF(ShtNm As String, Rng As Range, _
                               CmtHeight As Long, CmtWidth As Long) As Variant
 
 
    
    
End Function