使用VBA实现Excel合并相同内容的相邻单元格

标签：excel   vba   合并   csv   单元格   

写算法的数据分析时生成了csv文件，为了方便查看需要对部分单元格进行合并。

原始的CSV文件用Excel打开有大量如下形式的子表：

而我希望处理之后变成如下格式：

在网上搜索了很久，大多只能对某一列进行操作，而我需要对整个表格的行列都进行这个操作。

除此之外，因为是数据分析的表格，我还希望只对非数字开头的单元格进行合并，即行列标题。

经过多次尝试，终于在以前从来没用过VBA的情况下把这个问题解决了……
（写程序的过程中发现VBA的if居然没有短路操作，只好一层一层嵌套）

有两个值得注意的地方是，

首先，Excel中合并之后的单元格只有左上角的单元格保存的数值，所以需要从右下角往左上角合并；

其次，如果先合并了列，再合并行的话，会把当前单元格左上角的单元格也一起合并，而事实上那个单元格可能与当前单元格值不相同，
这时需要自己选择一个优先级，优先对行合并还是优先对列合并。

Sub MergeCellsWithSameValue()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dim r As Integer
    Dim c As Integer
    
    Sheet1.UsedRange.EntireRow.AutoFit
    Sheet1.UsedRange.EntireColumn.AutoFit
    Sheet1.UsedRange.HorizontalAlignment = xlCenter
    Sheet1.UsedRange.VerticalAlignment = xlCenter
    
    For r = Sheet1.UsedRange.Rows.Count To 1 Step -1
        For c = Sheet1.UsedRange.Columns.Count To 1 Step -1
            If Not IsEmpty(Cells(r, c)) Then
                If Not IsNumeric(Left(Cells(r, c).Value, 1)) Then
                    If r > 1 Then
                        If Not IsEmpty(Cells(r - 1, c).Value) Then
                            If Cells(r, c) = Cells(r - 1, c) Then
                                Range(Cells(r, c), Cells(r - 1, c)).Merge
                                GoTo NEXTLOOP
                            End If
                        End If
                    End If
                    If c > 1 Then
                        If Not IsEmpty(Cells(r, c - 1).Value) Then
                            If Cells(r, c) = Cells(r, c - 1) Then
                                Range(Cells(r, c), Cells(r, c - 1)).Merge
                                GoTo NEXTLOOP
                            End If
                        End If
                    End If
                End If
            End If
NEXTLOOP:
        Next
    Next

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

Excel 2013中测试有效。

使用VBA实现Excel合并相同内容的相邻单元格

标签：excel   vba   合并   csv   单元格   

原文地址：http://blog.csdn.net/phoenix_szx/article/details/44176409