Merge cells on formula values

[NikkiMc204]

Hello wise ones

I know everyone hates merged cells but i've asked/tasked with merging cells in a work spreadsheets. The information is pulled from another sheet with a formula =IFERROR(@INDEX(Table1[Project Name],FLOOR((ROW()-5)/10,1)+1),"") so each project line is repeated exactly 10 times and there's currently 70 odd projects so 700 rows.

I'm not allowed to download any helpful add ons like kutools that can quickly click and merge cells with formulas.

The outcome I'm after is to be able to merge the cells in columns b c d e f (every ten rows) column g is more variable (might be 10 or 20 rows) but i'd also like to merge where values are the same but i don't want to lose the values in order to ultimately pivot all the results

Is this even possible to do? open to all and any suggestions

 

[Bosquedeguate]

Yes, It is possible. How should the Merged values be displayed/formatted?

 

[NikkiMc204]

Yes, It is possible. How should the Merged values be displayed/formatted?

Oh erm aligned middle and centred

 

[Bosquedeguate]

Question ... will your Sheet alway be sorted by Project Title; i.e. can you assume that project records will be grouped together in the Sheet?

Here is a VBA Macro that will:

• turn off the warnings
• saves the original text from the cells
• merges the cells
• restores the saved text (one line for cell value merged. merged data is centered vertically and horizontally.
• changes the cell height so that the merge data displays (with linefeeds)
• restores warning messages.

I'll assume you can write the code to do the merge in the rows where you need it. Provide feedback if you need additional help.

Hint: an easy way to get started on code like this is to Turn On "Record Macro". Do the steps you want to do (and repeat). Turn Off (Stop) macro recording.
This will create a VBA macro you can start to work with and edit.

Sample code:

Sub Macro1()
'
' Macro1 Macro
'
  Dim rng As Range
  Dim ary, i
  Dim s As String
'
   
    Application.DisplayAlerts = False
    Set rng = Selection
    rng.Select
    ary = rng.Value
   
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
        For i = 1 To 5
          s = s & vbLf & ary(1, i)
        Next i
        .Value = Trim(s)
        .Height = 80
    End With
  Applcation.DisplayAlerts = True
End Sub

 

[Bosquedeguate]

How about something like this ... ?

Before Merge

MergeCells.xlsm
	A	B	C	D	E	F	G
1
2
3	Row	Project Title	Start	End	Status	Project Lead	Directorate
4		Project 1	44992	45137	Delivered	Name A	D1
5		Project 1	44992	45137	Delivered	Name A	D2
6		Project 1	44992	45137	Delivered	Name A	D3
7		Project2	44835	45124	Planning	Name B	D1
8		Project2	44835	45124	Planning	Name B	D2
9		Project2	44835	45124	Planning	Name B	D3
10		Project2	44835	45124	Planning	Name B	D4
11		Project2	44835	45124	Planning	Name B	D5
12		Project3	44501	45232	Ordered	Name C	D1
13		Project 4	44581	55001	Delivered	Name D	D1
14		Project 4	44581	55001	Delivered	Name D	D2
15		Project 4	44581	55001	Delivered	Name D	D3
16		Project 4	44581	55001	Delivered	Name D	D4
17		Project 4	44581	55001	Delivered	Name D	D5
18		Project 4	44581	55001	Delivered	Name D	D6
19		Project 4	44581	55001	Delivered	Name D	D7
20		Project 4	44581	55001	Delivered	Name D	D8
21		Project 4	44581	55001	Delivered	Name D	D9
22		Project 4	44581	55001	Delivered	Name D	D10
Sheet1

After Merge

MergeCells.xlsm
	A	B	C	D	E	F	G
1
2
3	Row	Project Title	Start	End	Status	Project Lead	Directorate
4		Project 1, 44992, 45137, Delivered, Name A					D1
5							D2
6							D3
7		Project2, 44835, 45124, Planning, Name B					D1
8							D2
9							D3
10							D4
11							D5
12		Project3	44501	45232	Ordered	Name C	D1
13		Project 4, 44581, 55001, Delivered, Name D, , , ,					D1
14							D2
15							D3
16							D4
17							D5
18							D6
19							D7
20							D8
21							D9
22							D10
Sheet3

Option Explicit

Sub Macro1()
'
' Macro1 Macro
'
  Dim rng As Range, rngMerge As Range
  Dim ary
  Dim s As String
  Dim r As Long, lr As Long, i As Long, rBegMerge As Long, rStart As Long
  Dim projRcds As Long
  Dim project As String
  
'
  rStart = WorksheetFunction.Match("Project Title", Range("B:B"), 0)
  lr = Range("B" & Rows.Count).End(xlUp).Row
    
  Application.DisplayAlerts = False
  
  rStart = rStart + 1
  project = ""
  projRcds = 0
  For r = rStart To lr + 1
    Set rng = Range("B" & r & ":F" & r)
    If project <> rng(1, 1) Then
      If projRcds > 1 Then 'merge cells
        Set rngMerge = Range("B" & rBegMerge & ":F" & r - 1)
      
        With rngMerge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = True
            For i = 1 To 5
              s = s & ", " & ary(1, i)
            Next i
            .Value = Mid(Trim(s), 3)
            s = ""
        End With
        project = rng(1, 1)
        projRcds = 0
      Else
      End If
      rBegMerge = r
      ary = rng.Value 'save the range data Cols B thru F
      project = rng(1, 1)
    End If
    projRcds = projRcds + 1
  Next r
  Application.DisplayAlerts = True
End Sub

 

[NikkiMc204]

They want it to show like this, if possible...

 

[Bosquedeguate]

OK --- how does this look?
Note the Macro code does not add the interior and exterior border lines. I did this manually in the unmerged Sheet.
The merge code does not modify the border lines, other than what happens when cells are merged.
(Of course this code could be added to the merge code in the future.)

Just a reminder this code does not sort the Sheet data. It assumes that the records are presorted and grouped together by Project Name.

Sheet Before merging cells

MergeCells.xlsm
	A	B	C	D	E	F	G
1
2
3	Row	Project Title	Start	End	Status	Project Lead	Directorate
4		Project1	7/30/2023	7/31/2023	On Track	Name A	D1
5		Project1	7/30/2023	7/31/2023	On Track	Name A	D2
6		Project1	7/30/2023	7/31/2023	On Track	Name A	D3
7		Project1	7/30/2023	7/31/2023	On Track	Name A	D4
8		Project1	7/30/2023	7/31/2023	On Track	Name A	D5
9		Project1	7/30/2023	7/31/2023	On Track	Name A	D6
10		Project1	7/30/2023	7/31/2023	On Track	Name A	D7
11		Project1	7/30/2023	7/31/2023	On Track	Name A	D8
12		Project1	7/30/2023	7/31/2023	On Track	Name A	D9
13		Project1	7/30/2023	7/31/2023	On Track	Name A	D10
14		Project 2	7/16/2023	7/25/2023	In Progress	Name A	D1
15		Project 2	7/16/2023	7/25/2023	In Progress	Name A	D2
16		Project 2	7/16/2023	7/25/2023	In Progress	Name A	D3
17		Project 2	7/16/2023	7/25/2023	In Progress	Name A	D4
18		Project 2	7/16/2023	7/25/2023	In Progress	Name A	D5
19		Project 2	7/16/2023	7/25/2023	In Progress	Name A	D6
20		Project 2	7/16/2023	7/25/2023	In Progress	Name A	D7
21		Project 2	7/16/2023	7/25/2023	In Progress	Name A	D8
22		Project 2	7/16/2023	7/25/2023	In Progress	Name A	D9
23		Project 2	7/16/2023	7/25/2023	In Progress	Name A	D10
Sheet1

Sheet After merging cells

MergeCells.xlsm
	A	B	C	D	E	F	G
1
2
3	Row	Project Title	Start	End	Status	Project Lead	Directorate
4		Project1	7/30/2023	7/31/2023	On Track	Name A	D1
5							D2
6							D3
7							D4
8							D5
9							D6
10							D7
11							D8
12							D9
13							D10
14		Project 2	7/16/2023	7/25/2023	In Progress		D1
15							D2
16							D3
17							D4
18							D5
19							D6
20							D7
21							D8
22							D9
23							D10
Sheet3

VBA Macro

Sub MergeProjectCells()
'
' Macro1 Macro
'
  Dim rng As Range, rngMerge As Range
  Dim c
  Dim ary
  Dim aryidx As Long
  Dim s As String
  Dim r As Long, lr As Long, i As Long, rBegMerge As Long, rStart As Long
  Dim projRcds As Long
  Dim project As String
  Dim shading As Boolean
  
'
  rStart = WorksheetFunction.Match("Project Title", Range("B:B"), 0)
  lr = Range("B" & Rows.Count).End(xlUp).Row
    
  Application.DisplayAlerts = False
  
  rStart = rStart + 1
  rBegMerge = rStart
  project = ""
  projRcds = 0
  shading = False
  For r = rStart To lr + 1
    Set rng = Range("B" & r & ":F" & r) ' & ",G" & r)
    'Look for a change in the project name
    If project <> rng(1, 1) Then
      If projRcds > 0 Then 'If more than 1 records for the Project Name merge them together
        If projRcds > 1 Then  'merge cells
          aryidx = 1
          For c = Asc("B") To Asc("F") 'do the merge Column by Column (Col B to E)
            Set rngMerge = Range(Chr(c) & rBegMerge & ":" & Chr(c) & r - 1)
            With rngMerge
              .HorizontalAlignment = xlCenter
              .VerticalAlignment = xlCenter
              .WrapText = False
              .Orientation = 0
              .AddIndent = False
              .IndentLevel = 0
              .ShrinkToFit = False
              .ReadingOrder = xlContext
              .MergeCells = True
              .Value = ary(1, aryidx)
            End With
            aryidx = aryidx + 1
          Next c
          project = rng(1, 1)
          projRcds = 0
        End If
        'Change the background shading for each project name change
        Set rngMerge = Range("B" & rBegMerge & ":E" & (r - 1) & ",G" & rBegMerge & ":G" & (r - 1))
        With rngMerge.Interior
          If shading Then
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -0.14996795556505  'change shading color here
          Else
            .Pattern = xlNone
            .TintAndShade = 0 'shading set to no color
          End If
          .PatternTintAndShade = 0
        End With
        shading = Not shading 'this toggles shading on and off
        rBegMerge = r
      End If
      
      ary = rng.Value 'save the range data Cols B thru F
      project = rng(1, 1)
    End If
 
    projRcds = projRcds + 1
  Next r
  
  'Merge all consecutive Project Lead values
  project = ""
  projRcds = 0
  rBegMerge = rStart
  For r = rStart To lr + 1
    Set rng = Range("F" & r)
    'Look for a change in the project name
    If project <> rng.Value And Not IsEmpty(rng.Value) Or r = lr Then
      If projRcds > 0 Then 'If more than 1 records for the Project Name merge them together
        If projRcds > 1 Then  'merge cells
          Set rngMerge = Range("F" & rBegMerge & ":" & "F" & r - 1)
          With rngMerge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = True
            .Value = project
          End With
          project = rng.Value
          projRcds = 0
        End If
      End If
      
      ary = rng.Value 'save the range data Cols B thru F
      project = rng.Value
    End If
 
    projRcds = projRcds + 1
  Next r

  
  Application.DisplayAlerts = True
End Sub

 

[NikkiMc204]

This is perfect thank you for taking the time to share this code with me