Macro to merge cells.

[sn152]

Hi All,

I am trying to create a macro which will merge cells. In the attached workbook there are 3 columns in sheet 1. In column A names are listed and in column B and C description and dates corresponding to that name is listed. Now what I want is to merge the same names in column A and also merge the dates corresponding to the names.
The output should look like the one on the sheet 2.

Please help me with this.

Thanks in advance!

 

[Hui]

Copy the following code into a VBA Code module in VBA

Run it

Sub Merge_data()

  Dim LR As Integer, i As Integer, SR As Integer
  Dim Rng As Range, Rng1 As Range, Rng2 As Range

  Worksheets("Sheet1").Select
  LR = Range("A" & Rows.Count).End(xlUp).Row
  Set Rng = Range(Cells(2, 1), Cells(LR, 3))
  Set Rng1 = Range(Cells(2, 1), Cells(LR, 1))
  Set Rng2 = Range(Cells(2, 3), Cells(LR, 3))


  Rng.Select
  ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
  ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Rng1 _
  , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Rng2 _
  , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  With ActiveWorkbook.Worksheets("Sheet1").Sort
  .SetRange Rng
  .Header = xlYes
  .MatchCase = False
  .Orientation = xlTopToBottom
  .SortMethod = xlPinYin
  .Apply
  End With
  SR = 2
  Application.DisplayAlerts = False
  For i = 2 To LR
 
  If Cells(i, 1).Value <> Cells(i + 1, 1).Value Or Cells(i, 3).Value <> Cells(i + 1, 3).Value Then
 
 
  Range(Cells(SR, 1), Cells(i, 1)).Select
  Selection.Merge
  With Selection
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlCenter
  End With
 
  Range(Cells(SR, 3), Cells(i, 3)).Select

  Selection.Merge
  With Selection
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlCenter
  End With
  SR = i + 1
  End If
  Next i
Application.DisplayAlerts = True
End Sub

I should add a caveat here, in that I never recommend anyone every merge cells for any reason. It makes subsequent reporting so difficult

I recommend that you use Conditional Formatting to achieve the following instead:

In the above the blank cells still contain the values meaning that reporting is possible

See attached file:

 

[sn152]

Thanks Hui for your help and advice...

 

[sn152]

One more question. This code works only for this range? If I add few more data to the range will it work? or should I change something? Please advice. Thanks!

 

[Hui]

It will work for any number of Rows as long as the data is in Columns A-C

It finds the Last Row using: LR = Range("A" & Rows.Count).End(xlUp).Row

 

[sn152]

Thanks Hui. Its working. In addition to the above, if I want to do the same merging in Column A, B, C and D how can I do it? Please help me. I have attached the updated workbook for your reference. Thanks!

 

[sn152]

Hi Hui,

Please note that I want to do the merging in column A, B, C, and E. Not D.
File attached in the previous post.

Thanks!

 

[Hui]

Place this code in the Worksheet code module in VBA and execute it
Please backup first just in case

Sub Merge_data()

  Dim LR As Integer, i As Integer, SR As Integer
  Dim Rng As Range, Rng1 As Range, Rng2 As Range

  Worksheets("Sheet1").Select
  LR = Range("A" & Rows.Count).End(xlUp).Row
  Set Rng = Range(Cells(2, 1), Cells(LR, 5))
  Set Rng1 = Range(Cells(2, 1), Cells(LR, 1))
  Set Rng2 = Range(Cells(2, 5), Cells(LR, 5))

  Rng.Select
  ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
  ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Rng1 _
  , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Rng2 _
  , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  With ActiveWorkbook.Worksheets("Sheet1").Sort
  .SetRange Rng
  .Header = xlYes
  .MatchCase = False
  .Orientation = xlTopToBottom
  .SortMethod = xlPinYin
  .Apply
  End With
  SR = 2
  Application.DisplayAlerts = False
  For i = 2 To LR
  If Cells(i, 1).Value <> Cells(i + 1, 1).Value Or Cells(i, 5).Value <> Cells(i + 1, 5).Value Then
  Range(Cells(SR, 1), Cells(i, 1)).Select
  Selection.Merge
  With Selection
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlCenter
  End With
  Range(Cells(SR, 2), Cells(i, 2)).Select

  Selection.Merge
  With Selection
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlCenter
  End With
 
  Range(Cells(SR, 3), Cells(i, 3)).Select

  Selection.Merge
  With Selection
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlCenter
  End With
 
  Range(Cells(SR, 5), Cells(i, 5)).Select

  Selection.Merge
  With Selection
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlCenter
  End With

 
  SR = i + 1
  End If
  Next i
Application.DisplayAlerts = True
End Sub

 

[sn152]

Hi Hui,

I think there is some problem. It is not merging correctly. Please check the attached file. I want to merge the data in A, B, C and E.

Pls. Note that the Number of Rows might vary.

Please help me.

Thanks!

 

[Hui]

The original file didn't have times in the dates

Simply change the one line as marked below:
If Cells(i, 1).Value <> Cells(i + 1, 1).Value Or Int(Cells(i, 5).Value) <> Int(Cells(i + 1, 5).Value) Then

 

[Hui]

Also remove the Conditional Formatting from the sheet
you don't need it

 

[sn152]

Cool... You are awesomeeee. Super it works... Thank you so much for your help.

 

[sn152]

Hi Hui,

I had another problem with the code today. It is not considering the 2nd row when sorting. Hence the 2nd row is not getting merged. Pls check the output in the attachment Sheet 1. The Sheet 4 has the exact data.

Thanks!

 

[sn152]

Hi Hui,

Please help me on this.

Thanks!