Question

我希望合并具有相同数据的单元格；

我想合并具有以下excel中类似值的单元格；

  |---------------------------|             |----------------------------|
  |Customer | FG | RPL   | DC |             |Customer | FG | RPL   | DC  |
  |---------+----+-------+----|             |---------+----+-------+-----|
  |A        | x  | alpha | 1  |             |A        | x  | alpha | 1   |
  |A        | x  | gamma | 5  |     ---->   |         |    | gamma | 5   |
  |A        | y  | alpha | 4  |             |         +----+-------+-----|
  |A        | y  | gamma | NA |             |         | y  | alpha | 4   |
  |B        | x  | gamma | 5  |             |         |    | gamma | NA  |
  |C        | x  | alpha | 1  |             |---------+----+-------+-----|
  |---------------------------|             |B        | x  | gamma | 5   |
                                            |---------+----+-------+-----|
                                            |C        | x  | alpha | 1   |
                                            |----------------------------|

我尝试了此代码，但不会合并第二列。

Set Rng = Range("B2:B8")
xRows = Rng(Rng.Count).Row
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
    Range("B2").Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge

    'Merging 2nd column
    Set SubRng = Range("B2").Parent.Range(Rng.Cells(i, 2), Rng.Cells(j - 1, 2))
    MsgBox SubRng.Address
    SubxRows = SubRng(SubRng.Count).Row
    For l = i To SubxRows - 1
        For m = l + 1 To SubxRows
            If SubRng.Cells(l, 1).Value <> SubRng.Cells(m, 1).Value Then
                Exit For
            End If
            Range("B2").Parent.Range(SubRng.Cells(l, 1), SubRng.Cells(m - 1, 1)).Merge
        Next
    Next

Next

Answer 1

同意Luuklag的评论，合并单元格是光滑的坡度，您可以将数据放入数据透视表，然后对其进行格式化。

也

Set Rng = Range("B2:B21")
xRows = Rng(Rng.Count).Row
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
Range("B2").Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge

'Merging 2nd column
Set SubRng = Range("B2").Parent.Range(Rng.Cells(i, 2), Rng.Cells(j - 1, 2))
i = j - 1 ' dirty fix jumping i to correct range
MsgBox SubRng.Address
SubxRows = SubRng(SubRng.Count).Row
For l = xI To SubxRows - 1
    For m = l + 1 To SubxRows
        If m > SubRng.Count Then Exit For

        If SubRng.Cells(l, 1).Value <> SubRng.Cells(m, 1).Value Then
            Exit For
        End If
    Next
     Range("B2").Parent.Range(SubRng.Cells(l, 1), SubRng.Cells(m - 1, 1)).Merge ' moved this line
Next

Next

合并代码必须位于“ For”循环之外，刚刚对其进行了测试，并意识到您的循环需要进行调整，添加了一个肮脏的快速修复程序来跳转变量“ i”，这现在应该可以工作。

Answer 2

我建议您不要合并任何东西并保留数据在适当的格式下以模仿合并

如下（假设B2：E8中的数据，而B2：E2中的标头）

Option Explicit

Sub MimicMerge()

    With Range("C3:E8").FormatConditions.Add(Type:=xlExpression, Formula1:="=$C3<>$C2")
        .Borders(xlTop).LineStyle = xlContinuous
        .StopIfTrue = False
    End With

    With Range("C3:C8").FormatConditions.Add(Type:=xlExpression, Formula1:="=AND($C3=$C2;$B3=$B2)")
        .Font.ThemeColor = xlThemeColorDark1
        .StopIfTrue = False
    End With

    With Range("B3:E8").FormatConditions.Add(Type:=xlExpression, Formula1:="=$B3<>$B2")
        .Borders(xlTop).LineStyle = xlContinuous
        .StopIfTrue = False
    End With

    With Range("B3:B8").FormatConditions.Add(Type:=xlExpression, Formula1:="=$B3=$B2")
        .Font.ThemeColor = xlThemeColorDark1
        .StopIfTrue = False
    End With

End Sub

之前

之后

Answer 3

尝试以下代码（代码中需要注释）：

Sub MergeCells()
    ' to prevent warnings from showing - we would get when merging
    Application.DisplayAlerts = False
    Dim lastRow As Long, i As Long, firstColumn As Long, firstRow As Long, startMergeRow1 As Long, startMergeRow2 As Long
    ' first column is A
    firstColumn = 1
    ' data starts in second row
    firstRow = 2
    lastRow = Cells(Rows.Count, firstColumn).End(xlUp).Row
    startMergeRow1 = firstRow
    startMergeRow2 = firstRow

    For i = 2 To lastRow
        ' if values in first column differ, then merge first and second column
        If Cells(i, firstColumn) <> Cells(i + 1, firstColumn) Then
            Range(Cells(startMergeRow1, firstColumn), Cells(i, firstColumn)).Merge
            Range(Cells(startMergeRow2, firstColumn + 1), Cells(i, firstColumn + 1)).Merge
            startMergeRow1 = i + 1
            startMergeRow2 = i + 1
        ' if values in second column differ, then merge only second column
        ElseIf Cells(i, firstColumn + 1) <> Cells(i + 1, firstColumn + 1) Then
            Range(Cells(startMergeRow2, firstColumn + 1), Cells(i, firstColumn + 1)).Merge
            startMergeRow2 = i + 1
        End If
    Next

    ' turn showing warnings on again
    Application.DisplayAlerts = False
End Sub

在两列的相邻行中合并具有相同数据的单元格

3 个答案: