如何合并excel中的类似单元格与VBA

Question

我是VBA中的新成员，但我尽我所能将单元格与宏组合在一起。
我需要确切的事情是相当复杂的：结合细胞在一排，如果他们有相同的字符串（和一个加是把边界的合并单元格）

在这里看到生动的例子：

example how to merge cells

我曾尝试使用此代码，但与以前的一个已经被合并的合并一个细胞时，它不能很好地工作，特别是。

你能给我一些帮助吗？

在此先感谢！

Sub Main() 

    Dim i As Long 
    Dim j As Long 

    For i = 1 To 5 
     For j = 1 To 15 
      If StrComp(Cells(i, j), Cells(i, j + 1), vbTextCompare) = 0 Then 
       Range(Cells(i, j), Cells(i, j + 1)).Merge 
       SendKeys "~" 
      End If 
     Next j 
    Next i 

End Sub 

Answer 1

或者你可以尝试这样的事情......

Sub MergeSimilarCells() 
Dim lr As Long, lc As Long, i As Long, j As Long 
lr = Cells(Rows.Count, 1).End(xlUp).Row 
Application.DisplayAlerts = False 
For i = 1 To lr 
    lc = Cells(i, Columns.Count).End(xlToLeft).Column 
    For j = 1 To lc 
     If Cells(i, j).MergeArea.Cells(1).Value = Cells(i, j + 1).MergeArea.Cells(1).Value Then 'Or Cells(i, j) = Cells(i, j - 1) Then 
      Range(Cells(i, j).MergeArea, Cells(i, j + 1)).Merge 
     End If 
    Next j 
Next i 
Range("A1").CurrentRegion.Borders.Color = vbBlack 
End Sub 

Answer 2

Sub Main() 

    Dim i As Long 
    Dim j As Long 
    Dim rws As Long 
    Dim clms As Long 
    Dim strt As Range 
    Dim endr As Range 

    With ActiveSheet 
     rws = .Cells(.Rows.Count, 1).End(xlUp).Row 'Find last row 
     clms = .Cells(1, Columns.Count).End(xlToLeft).Column 'Find last column 

     For i = 1 To rws 'iterate rows 
      Set strt = .Cells(i, 1) 'set start of range 
      For j = 2 To clms + 1 'iterate columns plus one 
       If strt.Value <> .Cells(i, j).Value Then 'check for change 
        Set endr = .Cells(i, j - 1) ' if change set end of range 
        Application.DisplayAlerts = False 
        .Range(strt, endr).Merge 'merge start to end 
        Application.DisplayAlerts = True 
        Set strt = .Cells(i, j) 'set new start range on new cell 
       End If 
      Next j 
     Next i 
     With .Range(.Cells(1, 1), .Cells(rws, clms)).Borders 'put border on entire range 
      .LineStyle = xlContinuous 
      .Weight = xlThin 
     End With 
    End With 

End Sub