You are here:

Excel/Neeed some help converting this macro to run as a as a shortcut key

Advertisement


Question
QUESTION: I am new to VBa and I thank everyone who has been great at giving me help and advice.  I saw a post were you answered a question in the same VBA code that I am using and wondered if you could help me.  I have been using the following code to automatically adjust the row height of a merged cell with warp text (thank you to whoever wrote this in the first place).  But for some reason the macro is slowing down my very large worksheet.  SO I want to convert it to a macro that will run off of a shortcut key instead of all the time.

I am using Excel 2007.

I would like the macro to start at the top of my work sheet and work to the bottom fixing the row heights.  here is the macro can you help me?

Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range
Dim ma As Range

With Target
If .MergeCells And .WrapText Then
Set c = Target.Cells(1, 1)
cWdth = c.ColumnWidth
Set ma = c.MergeArea
For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next
Application.ScreenUpdating = False
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.EntireRow.AutoFit
NewRwHt = c.RowHeight
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
Application.ScreenUpdating = True
End If
End With
End Sub

Thank Dereck

ANSWER: Dereck

Would need some idea of you data looks like.  Am I looping down one column?  which one?

will some of the merge cells be multiple rows?

--
Regards,
Tom Ogilvy


---------- FOLLOW-UP ----------

rows
rows  
QUESTION: it will be in one of three columns F, G  or H  I have a combination of these 3 merged together.  Either FG or GH or FGH.  there are no merged rows only columns. The spreadsheet is used as a master specification in a manufacturing facially  an example of a standard row would be as follows:

ANSWER: Dereck,

This is untested, but I believe this is what you want (may need some tweaking).  It walks down column F and looks for a merge area either starting in column F or Column G and then processes it with your original code.  Designed to work on the sheet that is active when the code is run.


Sub ProcessMergeCells()
Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range
Dim ma As Range
Dim Target as Range, Target1 as Range
Dim r as Range, r1 as Range, r2 as Range
set r = Activesheet.UsedRange
set r = Intersect(r.EntireRow, columns(5)).cells
for each target1 in r
 set r1 = Target1.MergeArea
 set r2 = Target1.offset(0,1).MergeArea
 if r1.MergeCells then
   set Target = r1
 elseif r2 = .MerceCells then
   set Target = r2
 else
   set Target = Target1
 end if
With Target
If .MergeCells And .WrapText Then
Set c = Target.Cells(1, 1)
cWdth = c.ColumnWidth
Set ma = c.MergeArea
For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next
Application.ScreenUpdating = False
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.EntireRow.AutoFit
NewRwHt = c.RowHeight
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
Application.ScreenUpdating = True
End If
End With
Next Target1
End Sub

--
Regards,
Tom Ogilvy


---------- FOLLOW-UP ----------

QUESTION: No it just froze Excel.  Let me go at this from a different Direction.  The original code I gave you worked great fro the last 2 years.  It was used everyday and never had a problem. It ran in the back gone I have it located in "Microsoft Excel Objects - Sheet1".  Now every time we hit return it take this macro about 2 mins to run through the sheet and fix the row height's #at least I assume it runs through the entire sheet each time#.  I figure that the problem is that the sheet has just gotten to big #4300 rows if information in just the first work sheet and a total of 35 worksheets of varying sizes#. My thought was to convert this macro so we only had to run it once when we were done editing the spreadsheet, hence my question to you.

What would be your suggestion?  We need this macro or one just like it because we use merged cells with word wrap and excel does not like to auto adjust the row height for these cells.  I am open for any and all help.

Thank you.

Answer
Dereck,

no, your original code does not process a whole column or the whole sheet.  It is fired/runs for any cell that you change, but if that cell is not merged with wraptext then it would do nothing.  But each time it runs, it does not process the whole sheet - otherwise you wouldn't have needed to contact me.

Now as I said, the code was untested and needed some tweaking.  One problem was I was looping down column E rather than column F - my bad.  But even doing that, it would have operated on any merged cell with wordwrap that stated in column F.  Anyway, I have modified the macro and tested it.  Once I got it running, I put in 5400 merged cells using the columns you specified.  

>Either FG or GH or FGH

the code ran in 1 minute and 6 seconds.  Now my sheet did not have event macros trying to run.  If you didn't remove the original event macro, that might be part of the problem.  To avoid that problem, I disable events at the top of the macro and enable them at the bottom.  If the macro errors before finishing, then events will need to be enabled.  

So here is the tested code.  It should go in a general module.  It will process the activesheet when it is run.  It will also report is progress in the status bar at the bottom of the excel window (make sure the status bar is visible).  I reports what row is being processed every 10th row.  It also reports the elapsed time.  It clears the status bar at the end, so you won't see the final elapsed time.  It will be reported in a msgbox at the end.

Sub ProcessMergeCells()
Dim dStart As Date, dEnd As Date
Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range
Dim ma As Range
Dim Target As Range, Target1 As Range
Dim r As Range, r1 As Range, r2 As Range
Set r = ActiveSheet.UsedRange
Set r = Intersect(r.EntireRow, Columns(6)).Cells
dStart = Time()
Application.EnableEvents = False
For Each Target1 In r
 If Target1.Row Mod 10 = 0 Then
   Application.StatusBar = Target.Row & " " & Format(Time() - dStart, "h:mm:ss")
 End If
 Set r1 = Target1.MergeArea
 Set r2 = Target1.Offset(0, 1).MergeArea
 If r1.MergeCells Then
   Set Target = r1
 ElseIf r2.MergeCells Then
   Set Target = r2
 Else
   Set Target = Target1
 End If
With Target
'Debug.Print Target.Address, Target.MergeCells, Target.WrapText
If .MergeCells And .WrapText Then
Set c = Target.Cells(1, 1)
cWdth = c.ColumnWidth
Set ma = c.MergeArea
For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next
Application.ScreenUpdating = False
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.EntireRow.AutoFit
NewRwHt = c.RowHeight
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
Application.ScreenUpdating = True
End If
End With
Next Target1
Application.StatusBar = False
Application.EnableEvents = True
MsgBox "Done: " & Format(Time() - dStart, "h:mm:ss")
End Sub

As I said, tested and worked for me.  If you have formulas in your sheet, you might want to set calculation to manual before you run the macro.  

--
Regards,
Tom Ogilvy

About Excel
This topic answers questions related to Microsoft Excel spreadsheet (or workbook) stand-alone or Mircrosoft Office Excel including Excel 2003, Excel 2007, Office 2000, and Office XP. You can get Excel help on Excel formulas(or functions), Excell macros, charting in Excel, advanced features, and the general use of Excel. This does not provide a general Excel tutorial nor the basics of using a spreadsheet. It provides specific answers to using Microsoft Excel only. If you do not see your Excel question answered in this area then please ask an Excel question here

Excel

All Answers


Answers by Expert:


Ask Experts

Volunteer


Tom Ogilvy

Expertise

Selected as an Excel MVP by Microsoft since 1999. Answering Excel questions in Allexperts since its inception in 2001. Able to answer questions on almost all aspects of Excel's internal capabilities. If seeking a VBA solution, please specify that in your question itself so I give you the answer you want. [Excel has weak protection - if you are distributing an application, I don't answer questions on how to protect your project from your users.]

Experience

Extensive experience.

Education/Credentials
Master of Science (MS) degree Operations Research (ORSA)

Awards and Honors
Microsoft MVP in Excel.

©2016 About.com. All rights reserved.