开发者

Merging variable rows within a selection individually

开发者 https://www.devze.com 2023-03-15 23:09 出处:网络
I have an Excel 2007 table which looks like this: /|A|B|C|D -+---------+----------+----------+----------+

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.


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

0

精彩评论

暂无评论...
验证码 换一张
取 消