Auto Row Height code

[Scott Taylor]

I'm grateful for the following code a member supplied to help me string together multiple cells with unique formatting into one cell while retaining the precise source cell formatting (including spacing), but when I use it the target cell (A11) will not autofit the row height. I could adjust the row manually, but it is a part of a series of called macros. Can anyone suggest code to insert within my macro?

Option Explicit

Sub Release_Combine_Text()
    Dim rng As Range, r As Range, txt As String, Temp As Long
    With Sheets("Release")
        Set rng = Range("A117", Range("A" & Rows.Count).End(xlUp))
    End With
    For Each r In rng
        txt = txt & r.Text
    Next
    With rng.Parent.Range("a11")
        .Value = txt
        For Each r In rng
            With .Characters(Temp + 1, Len(r.Text)).Font
                .FontStyle = r.Font.FontStyle
                .Size = r.Font.Size
                .Name = r.Font.Name
                .Color = r.Font.Color
                .Strikethrough = r.Font.Strikethrough
                .Subscript = r.Font.Subscript
                .Superscript = r.Font.Superscript
                .Underline = r.Font.Underline
            End With
            Temp = Temp + Len(r.Text)
        Next
    End With
End Sub

[gyclone]

Sub Release_Combine_Text()
    Dim rng As Range, r As Range, txt As String, Temp As Long
    With Sheets("Release")
        Set rng = Range("A117", Range("A" & Rows.Count).End(xlUp))
    End With
    For Each r In rng
        txt = txt & r.Text
    Next
    With rng.Parent.Range("a11")
        .Value = txt
        For Each r In rng
            With .Characters(Temp + 1, Len(r.Text)).Font
                .FontStyle = r.Font.FontStyle
                .Size = r.Font.Size
                .Name = r.Font.Name
                .Color = r.Font.Color
                .Strikethrough = r.Font.Strikethrough
                .Subscript = r.Font.Subscript
                .Superscript = r.Font.Superscript
                .Underline = r.Font.Underline
            End With
            Temp = Temp + Len(r.Text)
        Next
        
        '*************
        '**** NEW ****
        .Rows.AutoFit
        '*************
        
    End With
End Sub

[AlphaFrog]

Try this (not tested)...

Sub Release_Combine_Text()
    Dim rng As Range, r As Range, txt As String, Temp As Long
    With Sheets("Release")
        Set rng = Range("A117", Range("A" & Rows.Count).End(xlUp))
    End With
    For Each r In rng
        txt = txt & r.Text
    Next
    With rng.Parent.Range("A11")
        .Value = txt
        For Each r In rng
            With .Characters(Temp + 1, Len(r.Text)).Font
                .FontStyle = r.Font.FontStyle
                .Size = r.Font.Size
                .Name = r.Font.Name
                .Color = r.Font.Color
                .Strikethrough = r.Font.Strikethrough
                .Subscript = r.Font.Subscript
                .Superscript = r.Font.Superscript
                .Underline = r.Font.Underline
            End With
            Temp = Temp + Len(r.Text)
        Next
        .WrapText = True
        .Rows.AutoFit
    End With
End Sub

[Scott Taylor]

Well, I gave it try and the AutoFit didn't work. The Cell didn't change size to accommodate the expanded text. Any other thoughts?

[AlphaFrog]

Well, I gave it try and the AutoFit didn't work. The Cell didn't change size to accommodate the expanded text. Any other thoughts?

Maybe try this.

        .RowHeight = 200
        .WrapText = True
        .Rows.AutoFit

[gyclone]

If you can attach a sample of what you're actually working with, it would help. The above code works for me, but I'm just using random formatting for test.

[Scott Taylor]

Here's the master workbook. The "Release" Sheet is where I am trying to populate the cell A11 with the information. I've only entered a small portion of the data and conditional formatting at this point.

The code I'm trying to modify is as follows:

Option Explicit

Sub Release_Combine_Text()
    Dim rng As Range, r As Range, txt As String, Temp As Long
    With Sheets("Release")
        Set rng = Range("A117", Range("A" & Rows.Count).End(xlUp))
    End With
    For Each r In rng
        txt = txt & r.Text
    Next
    With rng.Parent.Range("A11")
        .Value = txt
        For Each r In rng
            With .Characters(Temp + 1, Len(r.Text)).Font
                .FontStyle = r.Font.FontStyle
                .Size = r.Font.Size
                .Name = r.Font.Name
                .Color = r.Font.Color
                .Strikethrough = r.Font.Strikethrough
                .Subscript = r.Font.Subscript
                .Superscript = r.Font.Superscript
                .Underline = r.Font.Underline
            End With
            Temp = Temp + Len(r.Text)
        Next
        .Rows.AutoFit
    End With
End Sub

[gyclone]

Hmm, all my tests seem to indicate that autofit just flat out doesn't work in this situation. Autofit works if the wrap text is on and the cells are unmerged, but the combination of wrapped text and merged cells seems to defeat the autofit, regardless of what order I apply the wrapping and merging in (through vba OR the GUI). I think you're going to have to go with a manual height, which does work. If the height is going to be variable, you can probably fake the autofit with some math in your vba, but, in my experience, it's incredibly difficult to make that work consistently in Excel.

[gyclone]

Some very basic testing would seem to indicate that you may be able to use a macro to Insert an Word Doc Object into the spread sheet, set the width you desire, then paste your formatted text into the Object. I don't have time to go down that road right now, but I think it will work, since it works when I do it manually.

[AlphaFrog]

This is a bit of a kludge but it works...

Sub Release_Combine_Text()
    Dim rng As Range, r As Range, txt As String, Temp As Long, rh As Single
    With Sheets("Release")
        Set rng = Range("A117", Range("A" & Rows.Count).End(xlUp))
    End With
    For Each r In rng
        txt = txt & r.Text
    Next
    Application.ScreenUpdating = False
    With rng.Parent.Range("A11")
        .Value = txt
        For Each r In rng
            With .Characters(Temp + 1, Len(r.Text)).Font
                .FontStyle = r.Font.FontStyle
                .Size = r.Font.Size
                .Name = r.Font.Name
                .Color = r.Font.Color
                .Strikethrough = r.Font.Strikethrough
                .Subscript = r.Font.Subscript
                .Superscript = r.Font.Superscript
                .Underline = r.Font.Underline
            End With
            Temp = Temp + Len(r.Text)
        Next
        .MergeCells = False
        .WrapText = True
        .Resize(, 13).HorizontalAlignment = xlCenterAcrossSelection
        .Rows.AutoFit
        'Below is only needed if you want the cells re-merged 
        '(I hate merged cells. They get in the way.)
            rh = .RowHeight
            .Resize(, 13).MergeCells = True
            .HorizontalAlignment = xlLeft
            .RowHeight = rh
        '''
    End With
    Application.ScreenUpdating = True
End Sub

[Scott Taylor]

Sounds like an intriguing proposal. I'm going to try that and see where it takes me. Thanks.

[Scott Taylor]

Alpha! it worked.....Thanks so much. I need to have the cell fully justified as well. I started it out as justified, but after running the macro it is aligned to the left.

This has been quite a learning curve for me...thanks to all who have contributed!