So verschmelzen ähnliche Zellen in Excel mit VBA

Question

Ich bin neu in VBA, aber ich versuche mein Bestes, um Zellen mit einem Makro zu kombinieren.
Das genaue was ich brauche, ist ziemlich kompliziert: Kombinieren Sie Zellen in einer Zeile, wenn sie die gleiche Zeichenfolge (und ein Plus ist eine Grenze in der fusionierten Zelle setzen)

Siehe Grafik Beispiel hier:

example how to merge cells

ich habe mit diesem Code versucht, aber es speziell funktioniert nicht gut, wenn eine Zelle mit einem früheren zusammen~~POS=TRUNC, die bereits zusammengeführt worden ist.

Können Sie mir Hilfe geben?

Vielen Dank im Voraus!

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

Oder Sie können so etwas wie dieses versuchen ...

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