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

我是VBA新手，但我正在尽我所能将单元格与macros相结合。
我需要的确切的东西是相当复杂的：如果它们具有相同的string，则将一行中的单元格合并在一起（并且在合并单元格中加一个边框）

在这里看到graphics例子：

示例如何合并单元格

我已经尝试过这个代码，但它不能很好地工作，特别是当合并一个单元格与已经合并的一个单元格。

你能帮我一下吗？

提前致谢！

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