单元格值匹配时合并单元格(不同的列行值)

时间:2019-03-12 06:32:32

标签: excel vba merge

我想编写一个Excel vba来根据单元格的值合并单元格并在另一列中引用单元格。就像所附的图片。 我有18000多行,有很多变化。 该行中的所有值均按顺序排列。

enter image description here

这是我基于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

2 个答案:

答案 0 :(得分:0)

编辑较小升级,可以扩展合并范围,从而启用合并更新。

合并具有相等值的垂直相邻单元格。

  • 保存在常规模块中。
  • 确保常量(Const)在模块中的任何其他代码之前。
  • 请考虑添加防护,以确保此防护仅针对工作表运行
    它用于(请参阅后面的代码)。
  • Alt - F8 宏对话中运行宏。
  • NB 与大多数宏一样,这将清除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(常量) 移到模块顶部。
  • 或将名称直接放在代码中:Worksheets("The Merge Tabs Name")

答案 1 :(得分:0)

将其添加到模块中,选择数据范围(不包括标头),运行宏,然后查看它是否对您有用。

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中看到我正在谈论的示例...

enter image description here

...已经计算出,上一列的分组在该点处停止,因此,不会继续进行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

请注意,我的建议是在运行任何代码之前,确保将原始源数据作为备份保存到另一个工作簿/工作表中。  如果其中包含您的数据,那么手动撤消将是一件很痛苦的事情。