Merging variable rows within a selection individually - vba

Question

I have an Excel 2007 table which looks like this:
/| A | B | C | D
-+---------+----------+----------+----------+
1| Item1 | Info a | 1200 | sum(C1:C2)
2| | | 2130 |
3| Item2 | Info b | 2100 | sum(C3:C7)
5| | | 11 |
6| | | 12121 |
7| | | 123 |
8| Item3 | Info c | 213 | sum(C8:C10)
9| | | 233 |
10| | | 111 |
What I hope to do is that whenever I select the entire table (A1:C10 for the above example) and press <Ctrl> + <M>, the macro code will automatically merge the blank cells with the cell above them that contains text e.g. A1 to A2; A3 to A7 and so forth. The same goes for column B. For column D, after merging, it would also sum up all the items in column C. I could do the merging and summation manually, however it would take me quite a while so I've been looking into macros to make life easier.
I would like to emphasize that the number of rows to merge on each item is variable (Item 1 has only 2 rows - A1 and A2, Item 2 has 4, and so on.)
Is this possible to do in Excel VBA? Any help and comments are greatly appreciated.

Answer 1

If you have a large number of rows, avoid looping through the cells themselves, as this is quite slow. Instaed copy the cells values to a Variant array first.
Option Explicit
Sub zx()
Dim rngTable As Range
Dim vSrcData As Variant
Dim vDestData As Variant
Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long
Set rngTable = Range("A1:D10")
vSrcData = rngTable
' vSrcData is now a two dimensional array of Variants
' set vDestData to an array of the right size to contain results
ReDim vDestData(1 To WorksheetFunction.CountA(rngTable.Columns(1)), _
1 To UBound(vSrcData, 2))
' keep track of row in Destination Data to store next result
i3 = LBound(vSrcData, 1)
' loop through the Source data
For i1 = 1 To UBound(vSrcData, 1) - 1
' sum the rows with blanks in clumn A
If vSrcData(i1, 1) <> "" Then
For i2 = i1 + 1 To UBound(vSrcData, 1)
If vSrcData(i2, 1) = "" Then
vSrcData(i1, 3) = vSrcData(i1, 3) + vSrcData(i2, 3)
Else
Exit For
End If
Next
' copy the result to Destination array
For i4 = 1 To UBound(vSrcData, 2)
vDestData(i3, i4) = vSrcData(i1, i4)
Next
i3 = i3 + 1
End If
Next
' delete original data
rngTable.ClearContents
' Adjust range to the size of results array
Set rngTable = rngTable.Cells(1, 1).Resize(UBound(vDestData, 1), _
UBound(vDestData, 2))
' put results in sheet
rngTable = vDestData
End Sub
Set Quick Key from Excel, Tools/Macros menu, Options