VBA合并相似的单元格

Question

我想按列合并相似的单元格，到现在为止我正在使用此宏

Sub MergeSimilarCells()

    Set myRange = Range("A1:Z300")

CheckAgain:
    For Each cell In myRange
        If cell.Value = cell.Offset(0, 1).Value And Not IsEmpty(cell) Then
            Range(cell, cell.Offset(0, 1)).Merge
            cell.VerticalAlignment = xlCenter
            cell.HorizontalAlignment = xlCenter
            GoTo CheckAgain
        End If
    Next

End Sub

我的问题是数百行40-50列，这需要永远。我很确定For Loop可以在那帮我，但我不够熟练，无法弄清楚]

我知道以下代码是错误的，但我迷路了

Sub SimilarCells()
  Set myRange = Range("A1:G4")
    Dim count As Integer

CheckAgain:
    count = 1

    For Each cell In myRange
        If cell.Value = cell.Offset(0, 1).Value And Not IsEmpty(cell) Then
            count = count + 1

        ElseIf cell.Value <> cell.Offset(0, 1).Value Then
            Range(cell, cell.Offset(0, -count)).Merge
        End If
    Next

End Sub

这是我想完成的

Answer 1

Sub MergeMe()    

    Dim wks As Worksheet: Set wks = Worksheets(1)
    Dim myRange As Range: Set myRange = wks.Range("B2:H5")
    Dim myCell As Range
    Dim myCell2 As Range

    Dim firstColumn As Long: firstColumn = myRange.Columns(1).column + 1
    Dim lastColumn As Long: lastColumn = firstColumn + myRange.Columns.Count - 1
    Dim firstRow As Long: firstRow = myRange.Rows(1).row
    Dim lastRow As Long: lastRow = firstRow + myRange.Rows.Count - 1
    Dim column As Long
    Dim row As Long

    OnStart

    For column = lastColumn To firstColumn Step -1
        For row = lastRow To firstRow Step -1
            Set myCell = wks.Cells(row, column)
            Set myCell2 = myCell.Offset(0, -1)
            If myCell.Value = myCell2.Value Then
                With wks.Range(myCell, myCell2)
                    .Merge
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlCenter
                End With
            End If
        Next row
    Next column

    OnEnd

End Sub

此代码中有很多技巧：

• 我们需要获取第一列和最后一列和行；
• 然后，我们应该从最后一个单元格（右下）循环到第一个单元格（左上）；
• 我们不应该输入第一列，因为我们使用的是.Offset(0,-1)，我们将每个单元格与其最左边的一个单元格进行比较；
• 整个操作的原因是默认情况下，合并单元格的值保留在其左上方的单元格中。合并单元格的其他单元格没有值。
• 这就是为什么我们总是将合并后的单元格与其“左”邻居进行比较；

这些是OnEnd和OnStart，便于操作。

Public Sub OnEnd()

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.AskToUpdateLinks = True
    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic
    ThisWorkbook.Date1904 = False
    Application.StatusBar = False

End Sub

Public Sub OnStart()

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.AskToUpdateLinks = False
    Application.DisplayAlerts = False
    Application.Calculation = xlAutomatic
    ThisWorkbook.Date1904 = False
    ActiveWindow.View = xlNormalView

End Sub

Answer 2

每组仅一个合并

编辑修复-感谢Vityata的单挑

Sub MergeEm()

    Dim rw As Range, i As Long, s As Long, v

    Range("C21:J33").Copy Range("C5:J17")  'for testing purposes: replace previous run

    Application.ScreenUpdating = False
    For Each rw In Range("C5:J17").Rows 'or wherever
        i = 1
        s = 1
        Do While i < (rw.Cells.Count)
            v = rw.Cells(i).Value
            'check for a run of same values
            Do While Len(v) > 0 And v = rw.Cells(i + s).Value
                s = s + 1
                If i + s > rw.Cells.Count Then Exit Do
            Loop
            'if s>1 then had a run: merge those ells
            If s > 1 Then
                Application.DisplayAlerts = False
                rw.Cells(i).Resize(1, s).Merge
                rw.Cells(i).HorizontalAlignment = xlCenter
                Application.DisplayAlerts = True
                i = i + s 'skip over the merged range
                s = 1     'reset s
            Else
                i = i + 1
            End If
        Loop
    Next rw
End Sub

Answer 3

我很确定您的处理时间过长导致goto导致每次合并后每次都循环遍历所有内容

编辑以考虑列A，并防止第一列单元格与myRange之外的单元格合并：

Sub MergeSimilarCells()

Dim i As Long
Dim myCol As String


Set myRange = Range("K1:L30")

myCol = Left(myRange.Address(True, False), InStr(myRange.Offset(0, 1).Address(True, False), "$") - 1)

If Not Intersect(myRange, Range(myCol & ":" & myCol)).Address = myRange.Address Then
    Set myRange = Range(Replace(myRange.Address, Left(myRange.Address(True, False), _
        InStr(myRange.Address(True, False), "$")), Left(myRange.Offset(0, 1).Address(True, False), _
        InStr(myRange.Offset(0, 1).Address(True, False), "$"))))
    For i = myRange.Cells.Count To 1 Step -1
        If myRange.Item(i).Value = myRange.Item(i).Offset(0, -1).Value And Not IsEmpty(myRange.Item(i)) Then
            Range(myRange.Item(i), myRange.Item(i).Offset(0, -1)).Merge
            myRange.Item(i).VerticalAlignment = xlCenter
            myRange.Item(i).HorizontalAlignment = xlCenter
        End If
    Next
End If

End Sub

为了阐明为什么myRange必须在B列中开始：Offset(0, -1)列中任何单元格的A将导致错误，因为A的左侧没有列。