Wrap text in Merged Cells macro

[steve case]

Yes, I really do want to merge cells!

I have several columns "A" thru "J" with simple contents, part#, qty, date, etc. and in column "K" descriptive text which can run several sentences long.

I'm trying to record a macro to insert a row, merge "A" thru "J" in that new row, cut the text from the "K" cell in the row above and select wrap text so it shows up below those headings so my user can read it.

Would look like:

part#, qty, date, etc, etc, etc, etc, etc, etc, etc
Blah blah blah blah blah blah blah blah blah blah blah
blah blah blah blah blah blah blah blah blah blah blah
blah blah blah blah blah blah blah blah

I can get it to look like that if I grab the row borders and drag it to fit, but can I get it to increase row height and wrap to fit the text length automatically with the macro?

Code looks like this so far:

Keyboard Shortcut: Ctrl+Shift+M
 
Application.CutCopyMode = False
    Selection.Insert Shift:=xlDown
    Range("A3:J3").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Range("K2").Select
    Selection.Cut
    Range("A3:J3").Select
    ActiveSheet.Paste
    Rows("5:5").Select

Dialog box pops up "This operation will cause some merged cells to unmerge. Do you wish to continue"

I'm going to have a shortcut key in the macro to do this one row at a time, as the data isn't that extensive, but I don't want to have to drag all the row heights.

 

[jasonb75]

Try this out on a copy of your workbook.

Will the macro always run the same cells or does the code need to be amended to run relative to the current selection?

Keyboard Shortcut: Ctrl Shift + M
Application.ScreenUpdating = False
    Selection.Insert Shift:=xlDown
    Range("A3:J3").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Range("A3") = Range("K2").Text
    Range("k2").ClearContents
    Rows("5:5").Select

Could be improved, but want to make sure this produces the desired result first.

JB

 

[steve case]

Thanks for the reply (-:

Didn't do any better than what I had tried to start out with.

The issue is, the automatic feature that sizes the row height to accomodate the contents, works for a single cell, but doesn't translate when cells are merged.

Hmmm and I don't know how do do this, but might I somehow use the formula =len(K3) and use the results to adjust the row height where the merged cells are?

The absolute reletive reference issue you brought up I'm sure I will solve, but you're right, I'm going to need to do that as I'm planning to [shft][ctrl+M] right down the page about 50 times everytime I run this which will be once a week until I drop dead or retire.

 

[jasonb75]

Ok, Quick change, without seeing exactly what you have in front of you this is a guesswork job, try selecting the cell in column k to copy to the merged cells then run the macro, see if I've got this right.

Code should run dynamic from the selected cell in K, regardless of row it should always put it in the right place, just not sure about row hight but took a guess on that, if it's wrong, try increasing or decreasing the value, in the line "Rows(addr).RowHeight = 28.5"

28.5 is double the height of a default row in a new sheet (default 14.25)

By predefining this value we can override the autofit.

Keyboard Shortcut: Ctrl Shift + M
Application.ScreenUpdating = False
    addr = ActiveCell.Row
    Rows(addr).Insert Shift:=xlDown
    Rows(addr).RowHeight = 28.5
    Range("A" & addr & ":J" & addr).Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Range("A" & addr) = Range("K" & addr + 1).Value
    Range("K" & addr + 1).ClearContents

 

[steve case]

Thanks for the effort, I think the key is the

Rows(addr).RowHeight = 28.5

line. I need to have that 28.5 a variable based on cell content, so if I do a search perhaps I'll find some code that will do that.

I think I've found something that Excel doesn't do which is automatically adjust merged cell height when wrap text is applied.

 

[jasonb75]

I have an idea Steve, can you post a real sample of the data from one of the cells, exactly as you want it to appear?

 

[jasonb75]

Thought I'd do a best guess code and post it, gives you something to play around with.

Usual drill, try it out on a copy file, it worked in testing, but don't know if it matches your data layout perfectly, so results could be unexpected.

This one is looped as well. select the first cell in column K that needs to be moved to merged cells, run the macro and let me know what happens.

'Keyboard Shortcut: Ctrl Shift + M
Application.ScreenUpdating = False
    addr = ActiveCell.Row
    
Do While Range("K" & addr).Value <> ""
    Rows(addr).Insert Shift:=xlDown
    Range("A" & addr & ":J" & addr).Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Range("A" & addr) = "=CEILING((LEN(K" & addr + 1 & ")/100)*14.25, 14.25)"
    rwh = Range("A" & addr).Value
    Rows(addr).RowHeight = rwh
    Range("A" & addr).Select
    Selection.ClearContents
    Range("A" & addr) = Range("K" & addr + 1).Value
    Range("K" & addr + 1).ClearContents
        
addr = addr + 2
Loop

 

[steve case]

It Works!!!!!

However, the headers for each of the Text Fields in Column "K" are on the bottom instead of the top )-:

I've read through your code, and I'm an amatuer at this stuff, so I haven't been able, so far, to figure out what to change to make them come out on top.

Should be:

A B C E D F G H I J
Blah blah blah blah
blah blah blah blah

Is:

Blah blah blah blah
blah blah blah blah
A B C D E F G H I J

But T H A N K Y O U !

I will get this to work

 

[jasonb75]

Try this one Steve, if it's still not quite right I'll need a bit more detail on your sheet layout to see where I'm going wrong.

Sub attempt_5()
'Keyboard Shortcut: Ctrl Shift + M
Application.ScreenUpdating = False
    addr = ActiveCell.Row
    
Do While Range("K" & addr).Value <> ""
    Rows(addr + 1).Insert Shift:=xlDown
    Range("A" & addr + 1 & ":J" & addr + 1).Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Range("A" & addr + 1) = "=CEILING((LEN(K" & addr & ")/100)*14.25, 14.25)"
    rwh = Range("A" & addr + 1).Value
    Rows(addr + 1).RowHeight = rwh
    Range("A" & addr + 1) = Range("K" & addr).Value
    Range("K" & addr).ClearContents
        
addr = addr + 2
Loop

End Sub

 

[steve case]

Thanks, I will try that, in either case, I'm home free as I wrote a little macro to cut & paste the rows where I want them:

Selection.Cut
    ActiveCell.Offset(-2, 0).Select
    ActiveSheet.Paste
    ActiveCell.Offset(4, 0).Select
    ActiveCell.Range("A1:J1").Select

Thank you for the code, I couldn't have done it woith out your help!