單元格值匹配時合並單元格（不同的列行值）

Question

我想編寫一個 Excel vba 來根據單元格的值和另一列中的引用單元格合並單元格。 就像附圖一樣。 我有超過 18000 行，有很多變化。 該行內的所有值均按順序排列。

在此處輸入圖片說明

這是我基於 VBA 的代碼

Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False 
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("B2:C10") 
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then 
Range(cell, cell.Offset(1, 0)).Merge
        GoTo MergeAgain
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Answer 1

編輯次要升級以允許擴展合並范圍以啟用合並更新。

合並具有相等值的垂直相鄰單元格。

• 保存在常規模塊中。
• 確保常量 ( Const ) 出現在模塊中的任何其他代碼之前。
• 考慮添加一個保護以確保這只針對工作表運行
  它適用於（請參閱代碼后的操作方法）。
• 從Alt - F8宏對話框運行宏。
• 注意像大多數宏一樣，這將擦除 Excel 撤消緩沖區。
  它無法通過Ctrl - Z撤消。 （唯一的選擇是恢復到上次保存
  或手動編輯為以前的方式。）

復制粘貼

Private Const LastCol = 20
Private Const LastRow = 20

Public Sub Merge_Cells()
    Dim r As Range
    Dim s As Range
    Dim l As Range
    Dim c As Long
    Dim v As Variant
    
    For c = 1 To LastCol
        Set s = Nothing
        Set l = Nothing
        For Each r In Range(Cells(1, c), Cells(LastRow, c))
            v = r.MergeArea(1, 1).Value
            If v = vbNullString Then
                DoMerge s, l
                Set s = Nothing
                Set l = Nothing
            ElseIf s Is Nothing Then
                Set s = r
            ElseIf s.Value <> v Then
                DoMerge s, l
                Set s = r
                Set l = Nothing
            Else
                Set l = r
            End If
        Next r
        DoMerge s, l
    Next c
End Sub

Private Sub DoMerge(ByRef s As Range, ByRef l As Range)
    If s Is Nothing Then Exit Sub
    If l Is Nothing Then Set l = s
    Application.DisplayAlerts = False
    With Range(s, l)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Merge
    End With
    Application.DisplayAlerts = True
End Sub

考慮以編程方式查找最后一列和最后一行。

如果合並應該在第 1 行之后開始：

For Each r In Range(Cells(1, c), Cells(LastRow, c))
                          ^

• 將1更改為正確的行號或替換為添加的const變量。

要保護其他工作表，請使用選項卡名稱（建議先重命名選項卡）：

For Each r In Worksheets(TabName).Range(Cells(1, c), Cells(LastRow, c))
              ^^^^^^^^^^^^^^^^^^^^

• 將此編輯與起始行編輯在同一行。
• 並添加Private Const TabName = "The Merge Tabs Name" ' Spaces ok
  到模塊的頂部與其他Const (constants) 。
• 或者將名稱直接放在代碼中： Worksheets("The Merge Tabs Name") 。

Answer 2

將此添加到模塊中，選擇您的數據范圍（不包括標題），運行宏並查看它是否適合您。

Public Sub MergeRange()
    Dim rngData As Range, lngRow As Long, lngCol As Long, strTopCell As String
    Dim strBottomCell As String, strThisValue As String, strNextValue As String
    Dim strThisMergeArea As String, strNextMergeArea As String

    Set rngData = Selection

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    With rngData
        For lngCol = 1 To .Columns.Count
            strTopCell = ""

            For lngRow = 1 To .Rows.Count
                If strTopCell = "" Then strTopCell = .Cells(lngRow, lngCol).Address

                strThisValue = .Cells(lngRow, lngCol)
                strNextValue = .Cells(lngRow + 1, lngCol)

                If lngCol > 1 Then
                    strThisMergeArea = .Cells(lngRow, lngCol - 1).MergeArea.Address
                    strNextMergeArea = .Cells(lngRow + 1, lngCol - 1).MergeArea.Address

                    If strThisMergeArea <> strNextMergeArea Then strNextValue = strThisValue & "."
                End If

                If strNextValue <> strThisValue Or lngRow = .Rows.Count Then
                    strBottomCell = .Cells(lngRow, lngCol).Address

                    With rngData.Worksheet.Range(strTopCell & ":" & strBottomCell)
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .MergeCells = True
                    End With

                    strTopCell = .Cells(lngRow + 1, lngCol).Address
                End If
            Next
        Next
    End With

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

對此有一個技巧可以更改，那就是它也將根據前一列進行分組。 您可以在單元格 C19 中看到我正在談論的內容的示例...

... 已經計算出前一列有一個在該點停止的分組，因此，1 沒有通過並分組到下一個批次，它停止並在那里分組。 我希望這是有道理的，我希望它能給你你所需要的。

另一件事，這里的代碼將嘗試分離您之前合並的所有數據。

Public Sub DeMergeRange()
    Dim rngData As Range, lngRow As Long, lngCol As Long, objCell As Range
    Dim objMergeArea As Range, strMergeRange As String, strFirstCell As String
    Dim strLastCell As String, objDestRange As Range

    Set rngData = Selection

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    With rngData
        For lngCol = 1 To .Columns.Count
            For lngRow = 1 To .Rows.Count
                Set objCell = .Cells(lngRow, lngCol)

                If objCell.Areas(1).MergeArea.Cells.Count > 1 Then
                    strMergeRange = objCell.Areas(1).MergeArea.Address

                    objCell.MergeCells = False

                    strFirstCell = Split(strMergeRange, ":")(0)
                    strLastCell = Split(strMergeRange, ":")(1)

                    Set objDestRange = .Worksheet.Range(.Worksheet.Range(strFirstCell).Offset(1, 0).Address & ":" & strLastCell)

                    .Worksheet.Range(strFirstCell).Copy objDestRange
                End If
            Next
        Next
    End With

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

注意，我的建議是確保在運行任何代碼之前將原始源數據保存到另一個工作簿/工作表作為備份。 如果它塞滿了您的數據，那么手動撤消將是一種正確的皇家痛苦。