合并重复单元格？

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