schnellste Möglichkeit, doppelte Zellen in ohne Excel zu verschmelzen

Question

Ich habe Zellen mit doppelten Werten, die ich schnell zusammenführen möchte. Die Tabelle sieht wie folgt aus:

Sub MergeCells() 
Application.DisplayAlerts = False 
Dim n As Name 
Dim fc As FormatCondition 
Dim Rng As Range, R As Range 
Dim lRow As Long 
Dim I&, J& 
Dim arr As Variant 

ReDim arr(1 To 1) As Variant 

With ThisWorkbook.Sheets("tst") 
    Set Rng = .Range("A2:D11") 
    lRow = Rng.End(xlDown).Row 

    For J = 1 To 4 
     For I = lRow To 2 Step -1 'last row to 2nd row 
      If Trim(UCase(.Cells(I, J))) = Trim(UCase(.Cells(I - 1, J))) Then 
       Set R = .Range(.Cells(I, J), .Cells(I - 1, J)) 
       arr(UBound(arr)) = R.Address 
       ReDim Preserve arr(1 To UBound(arr) + 1) 
      End If 
     Next I 
    Next J 
    ReDim Preserve arr(1 To UBound(arr) - 1) 

    Set R = .Range(Join(arr, ",")) 
    'MsgBox R.Areas.Count 
    'R.Select 
    'R.MergeCells = True 
    With R 
     .Merge 
     .HorizontalAlignment = xlCenter 
     .VerticalAlignment = xlCenter 
    End With 

    Stop 
End With 

Application.DisplayAlerts = True 
End Sub 

Die doppelten Zellen Bereiche unzusammenhängend oder nicht benachbarte Zellen sein könnte. Ich möchte einen Weg, um solche doppelten Bereiche schnell zu identifizieren und sie ohne Verwendung einer For-Schleife zusammenzuführen. [Weiß nicht, aber denke, es könnte einen schnellsten innovativen Weg ohne Schleifen geben, der wahrscheinlich eine Kombination von Excel-Array-Formeln und VBA-Code verwendet, um doppelte Zellbereiche auszuwählen und zusammenzuführen.]

BTW der obige Code funktioniert gut bis es schießt den folgenden Fehler bei Zeile .Merge.

EDIT Dies ist eine Momentaufnahme der Fenster-Uhr zeigt die arr Inhalte sowie R.Address.

OUTPUT: Sie keine Auswahl nicht benötigen, ist dies nur zu Demonstrationszwecken:

Ausgabe sollte wie folgt aussehen:

BEARBEITEN ... Angenommen, die doppelten Werte wären in allen Zeilen gleich? Also nur doppelte Spaltenwerte, die zusammengeführt werden sollen. Es muss eine schnelle, innovative Art geben, diese Zusammenführung zu tun.

Endausgabebild:

Answer 1

Das Problem ist, dass der Code nur zwei benachbarte Zellen finden kann und nicht auf der Suche nach einem dritten mit diesem Code: Set R = .Range(.Cells(I, J), .Cells(I - 1, J))

Nach dem erste Schleife fügt diese 2 Zellen hinzu

Nach einem anderen l oop es die nächsten zwei Zellen

Und dies führt zu einer überlappenden

fügt hinzu, die Sie bei der dunkleren Schattierung der Auswahl sehen können.

Ich habe gerade einen Teil Ihres Codes mit Kommentaren bearbeitet, damit Sie sehen können, wie es gemacht werden könnte. Aber ich bin mir sicher, dass es noch Raum für Verbesserungen gibt.

Sub MergeCellsNew() 
    Application.DisplayAlerts = False 
    Dim n As Name 
    Dim fc As FormatCondition 
    Dim Rng As Range, R As Range 
    Dim lRow As Long 
    Dim I&, J& 
    Dim arr As Variant 

    ReDim arr(1 To 1) As Variant 

    With ThisWorkbook.Sheets("tst") 
     Set Rng = .Range("A2:D11") 
     lRow = Rng.End(xlDown).Row 

     For J = 1 To 4 
      I = 2 'I = Rng.Row to automatically start at the first row of Rng 
      Do While I <= lRow 
       Set R = .Cells(I, J) 'remember start cell 

       'run this loop as long as duplicates found next to the start cell 
       Do While Trim(UCase(.Cells(I, J))) = Trim(UCase(.Cells(I + 1, J))) 
        Set R = R.Resize(R.Rows.Count + 1) 'and resize R + 1 
        I = I + 1 
       Loop 

       'now if R is bigger than one cell there are duplicates we want to add to the arr 
       'this way single cells are not added to the arr 
       If R.Rows.Count > 1 Then 
        arr(UBound(arr)) = R.Address 
        ReDim Preserve arr(1 To UBound(arr) + 1) 
       End If 
       I = I + 1 
      Loop 
     Next J 
     ReDim Preserve arr(1 To UBound(arr) - 1) 

     Set R = .Range(Join(arr, ",")) 
     With R 
      .Merge 
      .HorizontalAlignment = xlCenter 
      .VerticalAlignment = xlCenter 
     End With 

     Stop 
    End With 

    Application.DisplayAlerts = True 
End Sub