Excel中的VBA合并列

Question

我正在尝试写一个简单的东西，它将合并具有相同信息的excel中的单元格。 到目前为止，我得到的是以下内容：

Private Sub MergeCells()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim rngMerge As Range, cell As Range
    Set rngMerge = Range("B2:B1000") 'Set the range limits here
    Set rngMerge2 = Range("C2:C1000")

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 = False
    Application.ScreenUpdating = True


    For Each cell In rngMerge2
        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 = False
    Application.ScreenUpdating = True

End Sub

因此，我遇到的问题分为两个问题，首先，我试图使它适用于A-AK列，但是正如您在上面看到的那样，我不知道如何将其组合而不只是使其重复相同事情超过30次。 还有另一种方式将其分组。

同样，当我将范围分配给Range（“ AF2：AF1000”）和Range（“ AG2：AG1000”）时，Excel整体崩溃。 我希望大家能帮助我指引正确的方向。

Answer 1

在子例程中重复执行代码表明某些例程功能应提取到其自己的方法中。

性能

1000似乎是任意行： Range("B2:B1000") 。 应调整此范围以适合数据。

最好合并所有要合并的单元格并在单个操作中合并它们。

Application.DisplayAlerts不需要设置为True。 子程序结束后它将复位。

---

Public Sub MergeCells()
    Dim Column As Range
    Application.ScreenUpdating = False

    With ThisWorkbook.Worksheets("Sheet1")
        For Each Column In .Columns("A:K")
            Set Column = Intersect(.UsedRange, Column)
            If Not Column Is Nothing Then MergeEqualValueCellsInColumn Column
        Next
    End With

    Application.ScreenUpdating = True
End Sub

Sub MergeEqualValueCellsInColumn(Target As Range)
    Application.DisplayAlerts = False
    Dim cell As Range, rMerge As Range
    For Each cell In Target
        If cell.Value <> "" Then
            If rMerge Is Nothing Then
                Set rMerge = cell
            Else
                If rMerge.Cells(1).Value = cell.Value Then
                    Set rMerge = Union(cell, rMerge)
                Else
                    rMerge.Merge
                    Set rMerge = cell
                End If
            End If
        End If
    Next
    If Not rMerge Is Nothing Then rMerge.Merge
End Sub

Answer 2

在重新使用它之前，您一直在修改rngMerge中的单元格，但没有修改它的定义。 如果您从底部开始并逐步进行，这可能会更好，因为情况类似于插入或删除行。

Option Explicit

Private Sub MergeCells()

    Dim i As Long, c As Long, col As Variant

    Application.DisplayAlerts = False
    'Application.ScreenUpdating = false

    col = Array("B", "C", "AF", "AG")

    For c = LBound(col) To UBound(col)
        For i = Cells(Rows.Count, col(c)).End(xlUp).Row - 1 To 2 Step -1
            If Cells(i, col(c)).Value = Cells(i, col(c)).Offset(1, 0).Value And Not IsEmpty(Cells(i, col(c))) Then
                Cells(i, col(c)).Resize(2, 1).Merge
                Cells(i, col(c)).HorizontalAlignment = xlCenter
                Cells(i, col(c)).VerticalAlignment = xlCenter
            End If
        Next i
    Next c

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

我添加了一个包装循环，该循环循环从数组中拉出多个列。

我还注意到了子过程的“私有”性质，并且我猜这在工作表的私有代码表中（右键单击“名称”选项卡，“查看代码”）。 如果代码要在多个工作表上运行，则它属于公共模块代码表（在VBE中使用“插入”，“模块”），并且应在单元格中添加适当的父工作表引用。

Answer 3

看来您在rngMerge和rngMerge2上运行相同的过程，并且它们的大小相同。

我建议以下内容，您只需遍历各列，然后遍历各列中的单元格即可：

Option Explicit
Private Sub MergeCells()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim rngMerge As Range, cell As Range
    Dim rngFull As Range

    Set rngFull = Range("B2:AK1000")
    For Each rngMerge In rngFull.Columns
        For Each cell In rngMerge.Cells
            If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
                Range(cell, cell.Offset(1, 0)).Merge
                'Add formatting statements as desired
            End If
        Next cell
    Next rngMerge

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

注意按照书面规定，这将仅处理重复项。 如果您有三胞胎或三胞胎以上，则将只有两对组合。

Answer 4

我对问题的框架会有所不同。 您的代码将遍历范围内的每个单元格，将其与下一个单元格进行比较，如果两个值相等，则将它们合并在一起。 我认为将每个单元格与先前的单元格值进行比较会更加清楚。

另外，您可以遍历各列，以避免代码重复（如其他答案中所述）。

Sub MergeCells()
    Dim wks As Worksheet
    Dim mergeRange As Range
    Dim column As Range
    Dim cell As Range
    Dim previousCell As Range

    'Because the Sheets property can return something other than a single worksheet, we're storing the result in a variable typed as Worksheet
    Set wks = Sheets("Sheet1")

    'To run this code across the entire "used part" of the worksheet, use this:
    Set mergeRange = wks.UsedRange
    'If you want to specify a range, you can do this:
    'Set mergeRange = wks.Range("A2:AK1000")

    For Each column In mergeRange.Columns
        For Each cell In column.Cells
            If cell.Row > 1 Then
                'cell.Offset(-1) will return the previous cell, even if that cell is part of a set of merged cells
                'In that case, the following will return the first cell in the merge area
                Set previousCell = cell.Offset(-1).MergeArea(1)

                If cell.Value = previousCell.Value And Not IsEmpty(cell) Then
                    cell.Value = ""
                    wks.Range(previousCell, cell).Merge
                End If
            End If
        Next
    Next
End Sub

---

如果要在多个范围上运行此代码，可以将在一个范围内执行合并的代码隔离到其自己的Sub过程中：

Sub MergeCellsInRange(mergeRange As Range)
    For Each column In mergeRange.Columns
        For Each cell In column.Cells
            If cell.Row > 1 Then
                Set previousCell = cell.Offset(-1).MergeArea(1)
                If cell.Value = previousCell.Value And Not IsEmpty(cell) Then
                    cell.Value = ""
                    wks.Range(previousCell, cell).Merge
                End If
            End If
        Next
    Next
End Sub

并从您的主过程中多次调用它：

Sub MergeCells()
    Dim wks As Worksheet
    Dim mergeRange As Range
    Dim column As Range
    Dim cell As Range
    Dim previousCell As Range

    Set wks = Sheets("Sheet1")

    MergeRange wks.Range("A2:U1000")
    MergeRange wks.Range("AA2:AK1000")
End Sub

---

参考文献：

Excel对象模型

• 全球图纸属性 ， 图纸集合
• 工作表对象
  • UsedRange属性
• 范围对象
  • 单元格属性
  • 行属性
  • 抵销财产
  • MergeArea属性
  • 价值属性

VBA

• For Each ... In构造
• IsEmpty函数
• Dim声明
• Set陈述
• Sub陈述