Macro to merge cells of the same colour/pattern index

G

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.
 
J

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
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top