Merging Cells Based On Equal Value WIthin A Dynamic Range

[Ark68]

I am looking for some help with a VBA based process.

I have a worksheet in which there are several groups of different data. The groups are defined by their sorted values in column R. Their are groups of "D", "F", "C" etc. with each group holdinf a dynamic number of rows (if any). The groups are separated by blank rows.

What I need to do is assess the values in column B of only the "D" section, and merge those cells in column B, that have equal values.

For example ... starting data:

WS 29-May-23.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
2	data	<7:30P	data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
3	data	<7:30P	data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
4	data	<7:30P	data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
5	data	<8:00P	data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
6	data	<9:15P	data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
7	data	<9:15P	data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
8	data	<10:00P	data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
9	data	<10:00P	data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
10	data	<10:00P	data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
11	data	<11:00P	data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
12
13	data		data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	F
14	data		data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	F
15	data		data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	F
16
17	data		data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	C
18	data		data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	C
19	data		data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	C
Sheet20

Would result in:

WS 29-May-23.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
2	data	<7:30P	data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
3	data		data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
4	data		data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
5	data	<8:00P	data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
6	data	<9:15P	data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
7	data		data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
8	data	<10:00P	data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
9	data		data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
10	data		data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
11	data	<11:00P	data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	D
12
13	data		data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	F
14	data		data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	F
15	data		data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	F
16
17	data		data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	C
18	data		data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	C
19	data		data	data	data	data	data	data	data	data	data	data	data	data	data	data	data	C
Sheet20

 

[DanteAmor]

Hi Ark, it's a pleasure to respond to your threads again

Try this:

Sub Merging_Cells()
  Dim i&, f As Range
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Range("B:B").HorizontalAlignment = xlCenter
  Range("B:B").VerticalAlignment = xlCenter
  For i = 2 To Range("B" & Rows.Count).End(3).Row
    Set f = Range("B:B").Find(Range("B" & i).Value, , xlValues, xlWhole, xlByRows, xlPrevious, False)
    If f.Row > i Then
      Range(Range("B" & i), f).Merge
      i = f.Row
    End If
  Next
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​