基于列值合并单元格的 VBA 宏

Posted 2023-02-23

【中文标题】基于列值合并单元格的 VBA 宏

【英文标题】：VBA Macro to Merge Cells based on Column Values

【发布时间】：2019-08-22 10:01:22

【问题描述】：

我正在尝试使用基于列值的 VBA 合并 Excel 中的单元格。例如，在第一行，只要月份相同，就合并这些单元格。我试过以下代码：

Sub Main()

Dim j As Long

    For j = 1 To 13
        If StrComp(Cells(1, j), Cells(1, j + 1), vbTextCompare) Then
            Range(Cells(1, j), Cells(1, j + 1)).Merge
        End If

    Next j

End Sub

在这里，我将行固定为第一行并遍历列并检查下一个单元格值是否与当前值相同。但是，在输出中它合并了不正确的单元格。我在这里错过了什么？

【参考方案1】：

这更容易理解。

Application.DisplayAlerts = False
    With ThisWorkbook.Sheets("Sheet1")
        For i = 13 To 2 Step -1 'Loop from the last cell, and stop at the second column 
            If .Cells(1, i).Value = .Cells(1, i).Offset(, -1).Value Then
                .Range(.Cells(1, i), .Cells(1, i).Offset(, -1)).Merge
            End If
        Next i
    End With
Application.DisplayAlerts = True

【讨论】：

但值得一提的是，它的速度要慢得多（它比需要的合并频率更高）并且它有一个无用的With 语句（你的statemets 中没有一个使用With）。

@Pᴇʜ 首先，我认为您是该站点上最好的编码人员之一，并且您提供了可以帮助人们的精明答案。我并不是要贬低您的答案，只是提供一个替代示例。是的，它确实更频繁地合并，但它更容易理解，而且我认为在处理 OPs 问题中的小范围时，速度不是一个因素。感谢您指出我没有正确连接工作表焦点，我尝试始终设置工作表，因为当工作表未正确识别时，我看到了太多错误。我已经更新了我的代码。谢谢

只是不要被误解。我的评论并不是要抹黑你的答案。看到替代品总是很好的（我总是给他们点数）。但我认为也值得了解给定解决方案之间的差异。所以 pro “更容易理解” 带有 con “slower”。当然，速度并不总是一个相关因素，但如果任何未来的读者（有类似问题但数据量不同）阅读它并知道有什么区别，他/她可以根据自己的需要选择适当的答案。

【参考方案2】：

应该像这样工作......

Option Explicit

Public Sub MergeSameValuesInRow()
    Const iRow As Long = 1         'the row number
    Const FirstColumn As Long = 1  'first column with data in iRow

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")  'define your worksheet

    Dim LastColumn As Long  'find last used column in iRow
    LastColumn = ws.Cells(iRow, ws.Columns.Count).End(xlToLeft).Column

    Dim StartCell As Range  'remember the start cell (first occurence of a new value)
    Set StartCell = ws.Cells(iRow, FirstColumn)

    Dim iCol As Long
    For iCol = FirstColumn + 1 To LastColumn + 1  'loop through columns in iRow
        If ws.Cells(iRow, iCol).Value <> StartCell.Value Then  'if value changed …
            Application.DisplayAlerts = False  'hide merging messages
            ws.Range(StartCell, ws.Cells(iRow, iCol - 1)).Merge  'merge from start cell until one before value change
            Application.DisplayAlerts = True

            Set StartCell = ws.Cells(iRow, iCol)  'set start cell to the next value
        End If
    Next iCol
End Sub

它将改变这一点……

进入这个……

【讨论】：

我接受了 GMalc 的回答，因为它简短而简洁。但是，感谢您的回答！