Question

我有以下输入：

并希望得到以下输出：

预期的操作是在A列中搜索重复值（列已经排序）。 A中的每个重复值应合并为1个单元格。此外，合并B中的相同行（如果不同则取最高值，但可以安全地假设它们是相同的）。请勿触摸C.

我现在手动执行此操作，这是一个巨大的痛苦。我是VBA的新手，但似乎这是加快速度的简单方法。有什么提示吗？

Answer 1

Sub MergeCells()
    'set your data rows here
    Dim Rows As Integer: Rows = 20

    Dim First As Integer: First = 1
    Dim Last As Integer: Last = 0
    Dim Rng As Range

    Application.DisplayAlerts = False
    With ActiveSheet
        For i = 1 To Rows + 1
            If .Range("A" & i).Value <> .Range("A" & First).Value Then
                If i - 1 > First Then
                    Last = i - 1

                    Set Rng = .Range("A" & First, "A" & Last)
                    Rng.MergeCells = True
                    Set Rng = .Range("B" & First, "B" & Last)
                    Rng.MergeCells = True

                End If

                First = i
                Last = 0
            End If
        Next i
    End With
    Application.DisplayAlerts = True
End Sub

Answer 2

我已经做了几次......

Public Sub MergeDuplicates()

'disable alerts to avoid clicking OK every time it merges
Application.DisplayAlerts = False

'define the range
Dim r As Range
Set r = Sheets("Sheet1").Range("A1:B4")

'need a row counter
Dim i As Long
i = 1

'variables to store the value in A in a row and its upstairs neighbor
Dim this_A As String
Dim last_A As String

'step through the rows of the range
For Each rw In r.Rows
    If i > 1 Then   'only compare if this is not the first row - nothing to look backwards at!
        'get the values of A for this row and the one before
        this_A = rw.Cells(1, 1).Value
        last_A = rw.Cells(1, 1).Offset(-1, 0).Value

        'compare this A to the one above; if they are the same, merge the cells in both columns
        If this_A = last_A Then
            'merge the cells in column A
           Sheets("Sheet1").Range(r.Cells(i - 1, 1), r.Cells(i, 1)).Merge
            'merge the cells in column B
           Sheets("Sheet1").Range(r.Cells(i - 1, 2), r.Cells(i, 2)).Merge
        End If

    End If

i = i + 1 'increment the counter

Next rw

'enable alerts
Application.DisplayAlerts = True

End Sub

Answer 3

您已指出A列已分类;在我看来，列A和列B都应该排序，列A作为主键，列B作为辅助键。

Option Explicit

Sub wqwerq()
    Dim i As Long, d As Long

    Application.DisplayAlerts = False

    With Worksheets("sheet3")
        With .Cells(1, "A").CurrentRegion
            .Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
                        Key2:=.Columns(2), Order2:=xlDescending, _
                        Orientation:=xlTopToBottom, Header:=xlNo
            For i = .Rows.Count To 1 Step -1
                If Not .Cells(i, "B").MergeCells Then
                    d = Application.CountIfs(.Columns(1), .Cells(i, "A"), .Columns(2), .Cells(i, "B"))
                    If CBool(d - 1) Then
                        With .Cells(i, "B")
                            .Resize(d, 1).Offset(1 - d, 0).Merge
                            .HorizontalAlignment = xlCenter
                            .VerticalAlignment = xlCenter
                        End With
                    End If
                End If
                If i = Application.Match(.Cells(i, "A"), .Columns(1), 0) Then
                    d = Application.CountIfs(.Columns(1), .Cells(i, "A"))
                    If CBool(d - 1) Then
                        With .Cells(i, "A")
                            .Resize(d, 1).Merge
                            .HorizontalAlignment = xlCenter
                            .VerticalAlignment = xlCenter
                        End With
                    End If
                End If
            Next i
        End With
    End With

    Application.DisplayAlerts = True

End Sub

Answer 4

尝试一下，易于适应，因为可以修改范围而无需更改其他任何内容。

Sub MergeRng
Dim Rng As Range, xCell As Range, WorkRng As Range
Dim xRows As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set WorkRng = Activeworkbook.ActiveSheet.Range("A1:B4")
xRows = WorkRng.Rows.Count
For Each Rng In WorkRng.Columns
    For i = 1 To xRows - 1
        For j = i + 1 To xRows
            If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
                Exit For
            End If
        Next
        With WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1))
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        i = j - 1
    Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

来源：

https://www.extendoffice.com/documents/excel/1138-excel-merge-same-value.html

合并重复的细胞？

4 个答案: