Question

我想将两个单元合并为一个，如果合并，我必须为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

感谢您对此事的帮助！

此致萨米特

Answer 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

它不是疯狂的优雅，但我测试它，它的工作:)祝你好运

使用VBA / Macro合并多列中的两个单元格

1 个答案: