excel - VBA 在 Excel 中合并列

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