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