Macro to merge cells of the same colour/pattern index

[Gary Capindale]

Hi guys,

I am hoping that some one here can help me,

First off i have a very, very basic knowledge of excel and vba so please
bear with me and i will try to describe what it is i am trying to do as best
as possible.

I have a worksheet that has a list of equipment down the left hand side and
week numbers going across the top 1 to 52. The spreadsheet is essentially a
plan of what equipment is being used by certain processes, represented by
coloured or patterned formatted cells in the weeks they will be in use. Kind
of like a gantt chart. Currently i have a spreadsheet were i copy the current
plans colours across to a template spreadsheet to tidy it up. I need to merge
and centre justify the cells in order to give each block a process name.

I am trying to go from left to right from weeks 1 to 52 and merge any cell
of the same colour or pattern if they are situated in direct proximity to one
another. I would also like to merge top to bottom as well as some processes
use multiple sets of equipment so would require to be merged across rows as
well.

I have tried to figure this out by recording macros, but they are massive
and don't work quite right. Obviously some kind of loops would be more
efficient. But i have no knowledge of how these things work really.

Thanks.

Gary.

 

[Jacob Skaria]

Thanks for the feedback. Modified to suit your req..

Sub MergebyColorIndex()

Dim arrRange() As Range, arrIndex() As Variant
Dim cell As Range, blnFound As Boolean, intTemp As Integer

ReDim arrRange(0): ReDim arrIndex(0)

For Each cell In Range("E5:BD38")
If cell.Interior.ColorIndex <> xlColorIndexNone Then
blnFound = False

For intTemp = 1 To UBound(arrIndex)
If arrIndex(intTemp) = cell.Interior.ColorIndex Then
Set arrRange(intTemp) = Union(arrRange(intTemp), cell)
blnFound = True: Exit For
End If
Next

If blnFound = False Then
ReDim Preserve arrRange(intTemp)
ReDim Preserve arrIndex(intTemp)
arrIndex(intTemp) = cell.Interior.ColorIndex
Set arrRange(intTemp) = cell
End If

End If
Next

For intTemp = 1 To UBound(arrRange)
With arrRange(intTemp)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.ShrinkToFit = False
.MergeCells = False
End With
arrRange(intTemp).Merge
Next

End Sub