1

我想将两个单元格合并为一个单元格，如果合并，我必须对 2000+ 行（1000+）执行此操作。我正在寻找一个可以帮助解决这个问题的宏。下面是我想做的一个例子..

我已经使用了基本的宏记录器及其很多我有硬代码的单元格，我有 2003 行我也需要执行以下操作。

Sub Macro2()
'
' Macro2 Macro
'

'
    Range("A28:A29,C28:C29,E28:E29,F28:F29").Select
    Range("F28").Activate
    With Selection
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Range("A1").Select
End Sub

下面是我要合并的数据示例... http://i.stack.imgur.com/US0MG.jpg

Number  Def Name1   Name2   Group1  Group2
12345   1   abcd             1       2
12345   2   abcd             1       2
123456  1   abcde            5       8
123456  2   abcde            5       8
123789  1   qwert            2       5
123789  2   qwert            2       5

合并后，我想看到以下内容：http: //i.stack.imgur.com/Pz0tb.jpg

Number  Def Name1   Name2   Group1  Group2
12345    1  abcd                 1       2
         2              
123456   1  abcde                5       8
         2              
123789   1  qwert                2       5
         2

感谢您在这件事上的帮助！

问候， 萨米特

4

1 回答 1

1 
Sub mergerizer()

Application.DisplayAlerts = False

Dim r As Integer
Dim mRng As Range
Dim rngArray(1 To 4) As Range
r = Range("A65536").End(xlUp).Row

For myRow = r To 2 Step -1

    If Range("A" & myRow).Value = Range("A" & (myRow - 1)).Value Then

        For cRow = (myRow - 1) To 1 Step -1

            If Range("A" & myRow).Value <> Range("A" & cRow).Value Then

                Set rngArray(1) = Range("A" & myRow & ":A" & (cRow + 1))
                Set rngArray(2) = Range("C" & myRow & ":C" & (cRow + 1))
                Set rngArray(3) = Range("E" & myRow & ":E" & (cRow + 1))
                Set rngArray(4) = Range("F" & myRow & ":F" & (cRow + 1))

                For i = 1 To 4
                    Set mRng = rngArray(i)
                    mRng.Merge
                    With mRng
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlTop
                        .WrapText = False
                        .Orientation = 0
                        .AddIndent = False
                        .IndentLevel = 0
                        .ShrinkToFit = False
                        .ReadingOrder = xlContext
                        .MergeCells = True
                    End With

                Next i

                myRow = cRow + 1
                Exit For
            End If
        Next cRow
    End If
Next myRow

Application.DisplayAlerts = True

End Sub

它不是疯狂的优雅，但我测试了它并且它有效:)祝你好运

于 2013-08-08T19:07:54.753 回答