le moyen le plus rapide de fusionner des cellules dupliquées sans boucler Excel

Question

J'ai des cellules contenant des valeurs en double que je veux fusionner rapidement. Le tableau ressemble à ceci:

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 

Les gammes de cellules en double pourraient être des cellules disjointes ou non adjacentes. Je veux un moyen d'identifier rapidement ces plages dupliquées et de les fusionner sans utiliser de boucle For. [Je ne sais pas, mais je pense qu'il pourrait y avoir un moyen innovant sans boucles utilisant probablement une combinaison de formules matricielles Excel et de code VBA, pour sélectionner et fusionner des plages de cellules dupliquées.]

BTW le code ci-dessus fonctionne bien jusqu'à ce qu'il déclenche l'erreur suivante à la ligne . Fusionner.

EDIT Voici un aperçu de la fenêtre Watch font état contenu arr ainsi que R.Address.

SORTIE: Ne pas besoin des sélections, c'est juste à des fins de démonstration:

sortie devrait ressembler à ceci:

EDIT ... Supposons que les valeurs en double soient identiques sur les lignes? Donc, seules les valeurs des colonnes en double doivent être fusionnées. Il doit y avoir un moyen rapide et innovant de faire cette fusion.

image Sortie finale:

Answer 1

Le problème est que votre code ne peut trouver 2 cellules adjacentes et ne cherche pas d'un troisième avec ce code: Set R = .Range(.Cells(I, J), .Cells(I - 1, J))

Après la première boucle, il ajoute ces 2 cellules

Après un autre l oop il ajoute les 2 prochaines cellules

Et cela se traduit par un chevauchement

que vous pouvez voir à l'ombrage plus sombre de la sélection.

Je viens d'éditer une partie de votre code avec des commentaires, vous pouvez donc voir comment cela pourrait être fait. Mais je suis sûr qu'il y a encore de la place pour des améliorations.

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