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陳述