I am trying to enter code to auto-expand merged cells. I have multiple ranges
within the same worksheet that will be affected by this macro. I believe that
I have reached the maximum range length for the macro. I need to add more
cells. How would I go about adding them to this macro OR can I add a second
macro for the additional cells?

Here is what I currently have:

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

Set r =
Range("A18:G18,A19:G19,A20:G20,A21:G21,A22:G22,A24 :D24,A25:D25,A26:D26,E24:H24,E25:H25,E26:H26,A30:G 30,A31:G31,A32:G32,A33:G33,A34:G34,A36:D36,A37:D37 ,A38:D38,E36:H36,E37:H37,E38:H38,D41:H41,D42:H42,D 43:H43,D45:H45,D47:H47,D48:H48,D49:H49,D51:H51,D44 :E44,D50:E50")
If Not Intersect(Target, r) Is Nothing 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 Sub

You can build a collection of ranges. Just list out your ranges in the
collection, then you can use a For...Each Loop to loop thru the ranges. Hope
this helps! If so, let me know, click "YES" below.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim NewRwHt As Single
Dim cWdth As Single
Dim MrgeWdth As Single
Dim c As Range
Dim cc As Range
Dim ma As Range
Dim colMyRanges As Collection
Dim rng As Range

Set colMyRanges = New Collection
With colMyRanges
.Add Range("A18:G18")
.Add Range("A19:G19")
.Add Range("A20:G20")
.Add Range("A21:G21")
.Add Range("A22:G22")
.Add Range("A24:D24")
.Add Range("A25:D25")

' add the rest of your ranges here

End With

For Each rng In colMyRanges

If Not Intersect(Target, rng) Is Nothing 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 cc

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
Next rng

End Sub
--
Cheers,
Ryan


"CC-AAP" wrote:

I am trying to enter code to auto-expand merged cells. I have multiple ranges
within the same worksheet that will be affected by this macro. I believe that
I have reached the maximum range length for the macro. I need to add more
cells. How would I go about adding them to this macro OR can I add a second
macro for the additional cells?

Here is what I currently have:

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

Set r =
Range("A18:G18,A19:G19,A20:G20,A21:G21,A22:G22,A24 :D24,A25:D25,A26:D26,E24:H24,E25:H25,E26:H26,A30:G 30,A31:G31,A32:G32,A33:G33,A34:G34,A36:D36,A37:D37 ,A38:D38,E36:H36,E37:H37,E38:H38,D41:H41,D42:H42,D 43:H43,D45:H45,D47:H47,D48:H48,D49:H49,D51:H51,D44 :E44,D50:E50")
If Not Intersect(Target, r) Is Nothing 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 Sub

If the multi-area address is over 255, break it down into separate addresses
of less than 255, then Union, something like this -

set r = Range(s1)
set r = Union(r, Range(s2))
etc

I haven't really looked at the rest of what you are doing. Probably worth
experimenting to see if better to make the big multi area range, or loop
smaller ranges, eg

ReDim arrAddresses(1 to 5) '
arrAddresses(1) = "1st address-less-than-255"
etc

for i = 1 to ubound( arrAddresses)
set r = range(arrAddresses(i))
do-stuff with r
next

Regards,
Peter T


"CC-AAP" wrote in message
...
I am trying to enter code to auto-expand merged cells. I have multiple
ranges
within the same worksheet that will be affected by this macro. I believe
that
I have reached the maximum range length for the macro. I need to add more
cells. How would I go about adding them to this macro OR can I add a
second
macro for the additional cells?

Here is what I currently have:

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

Set r =
Range("A18:G18,A19:G19,A20:G20,A21:G21,A22:G22,A24 :D24,A25:D25,A26:D26,E24:H24,E25:H25,E26:H26,A30:G 30,A31:G31,A32:G32,A33:G33,A34:G34,A36:D36,A37:D37 ,A38:D38,E36:H36,E37:H37,E38:H38,D41:H41,D42:H42,D 43:H43,D45:H45,D47:H47,D48:H48,D49:H49,D51:H51,D44 :E44,D50:E50")
If Not Intersect(Target, r) Is Nothing 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 Sub