Macro to merge cells

[dment]

Hi

I a trying to create a macro that will merge a number of cells in a column based on a value in another cell

the spreadsheet is laid out

Column A Column B Column C Column D Column E

City ProductID Cost Total Amount Count
London 001 £1.00 £7.00 5
London 002 £2.00
London 008 £8.00
London 004 £4.00
London 002 £2.00
Birmingham 003 £3.00 £20.00 5
Birmingham 005 £5.00
Birmingham 004 £4.00
Birmingham 005 £5.00
Birmingham 003 £3.00
Manchester 001 £1.00 £16.00 6
Manchester 002 £2.00
Manchester 004 £4.00
Manchester 001 £1.00
Manchester 005 £5.00
Manchester 003 £3.00

I need to merge column D for each city.
I had a macro that used xlDown but this takes it down to the bottom of the workbook rather than the next cell which has a figure in (This is due to the spreadsheet having a formula in the cells) so I think I will need to use the count figure in column E

Any help will be much appreciated.

 

[DanteAmor]

If you need the sum of the Cost, try this

Book1
	A	B	C	D	E	F
1	City	ProductID	Cost	Total	Amount	Count
2	London	1	1	17	5
3	London	2	2
4	London	8	8
5	London	4	4
6	London	2	2
7	Birmingham	3	3	20	5
8	Birmingham	5	5
9	Birmingham	4	4
10	Birmingham	5	5
11	Birmingham	3	3
12	Manchester	1	1	16	6
13	Manchester	2	2
14	Manchester	4	4
15	Manchester	1	1
16	Manchester	5	5
17	Manchester	3	3
Sheet1

Cell Formulas
Range	Formula
D2	=IF(COUNTIF($A$2:A2,A2)=1,SUMIF($A$2:$A$17,A2,$C$2:$C$17),"")

 

[dment]

Thanks but it's not the sum that I want. The example didn't come out as it should have.

Based on your pic column D should be Total Amount and column E is the count.

I need Macro that will merge column D based on the count n column E

so Cells D2 to D6 will be merged. D7 to D11 will be merged and so on

 

[DanteAmor]

Based on my pic, cell D2 has value, cells D3 to D6 are empty, and so on.
If the above is correct, then try the following:

Sub merge_cells()
  Dim c As Range
  For Each c In Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).Areas
    With c.Offset(-1).Resize(c.Rows.Count + 1)
      .MergeCells = True
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
    End With
  Next
End Sub

 

[dment]

Thank you. That works in my test spreadsheet but not on the one I need it to work on. problem is the spreadsheet is created from one that has formulas in column D so while the cells are blank End + Down takes you to the end of the column rather than the next number. If I click in each cell in column D before running the macro it works fine. This is why I included column E which holds the number of cells to be merged.

Any ideas of how best to get round this problem?

 

[Fluff]

If col D had formulae that returned "", try

Sub merge_cells()
    Dim c As Range
    With Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row)
        .Value = .Value
        For Each c In .SpecialCells(xlCellTypeBlanks).Areas
            With c.Offset(-1).Resize(c.Rows.Count + 1)
                .MergeCells = True
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
        Next c
    End With
End Sub

 

[DanteAmor]

In column E do you also have formulas?

Do you want to keep the formula in column D, in this case on the merged cell?

Try this:

Sub merge_cells2()
  Dim ant As Variant, i As Long, ini As Long
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  ini = 2
  ant = Range("A2").Value
  For i = 2 To Range("A" & Rows.Count).End(xlUp).Row + 1
    If ant <> Cells(i, "A").Value Then
      With Range("D" & ini & ":D" & i - 1)
        .MergeCells = True
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
      End With
      ini = i
    End If
    ant = Cells(i, "A").Value
  Next
End Sub

 

[dment]

Thanks. That is almost what I am after. the cells merge OK apart from the last one. the original formula goes down to row 25 so the amount for Manchester merges D12 to D25 instead of D12 to D17

 

[dment]

Thanks. That is almost what I am after. the cells merge OK apart from the last one. the original formula goes down to row 25 so the amount for Manchester merges D12 to D25 instead of D12 to D17

This was in reply to the macro from Fluff

 

[DanteAmor]

I don't know how you have the formulas.
You could put how you have the formulas.
Or change the references of the formulas to absolute, that is, if you have this: D12:D17 you must change it to: $D$12:$D$17