La fusion des deux Cellules dans plusieurs colonnes à l'aide de VB/Macro

Je voudrais fusionner deux cellules comme un et je dois le faire pour 2000+ lignes (1000+) si fusionné. Je suis à la recherche d'une macro qui vous aidera dans cette démarche. Ci-dessous est un exemple de ce que je voudrais faire..

J'ai utilisé la base de l'enregistreur de macro et de ses beaucoup de cellules que j'ai le code, j'ai 2003 lignes que j'ai besoin de faire le dessous de trop.

Sub Macro2()
'
' Macro2 Macro
'

'
    Range("A28:A29,C28:C29,E28:E29,F28:F29").Select
    Range("F28").Activate
    With Selection
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Range("A1").Select
End Sub

Ci-dessous est un exemple des données que je veux fusionner...
http://i.stack.imgur.com/US0MG.jpg

Number  Def Name1   Name2   Group1  Group2
12345   1   abcd             1       2
12345   2   abcd             1       2
123456  1   abcde            5       8
123456  2   abcde            5       8
123789  1   qwert            2       5
123789  2   qwert            2       5

Après la fusion , je voudrais voir ci-dessous:
http://i.stack.imgur.com/Pz0tb.jpg

Number  Def Name1   Name2   Group1  Group2
12345    1  abcd                 1       2
         2              
123456   1  abcde                5       8
         2              
123789   1  qwert                2       5
         2

Merci pour votre aide dans cette affaire!

Ce qui concerne,
Samit

InformationsquelleAutor Samit Lal | 2013-08-08
  1. 1
    Sub mergerizer()
Application.DisplayAlerts = False
Dim r As Integer
Dim mRng As Range
Dim rngArray(1 To 4) As Range
r = Range("A65536").End(xlUp).Row
For myRow = r To 2 Step -1
If Range("A" & myRow).Value = Range("A" & (myRow - 1)).Value Then
For cRow = (myRow - 1) To 1 Step -1
If Range("A" & myRow).Value <> Range("A" & cRow).Value Then
Set rngArray(1) = Range("A" & myRow & ":A" & (cRow + 1))
Set rngArray(2) = Range("C" & myRow & ":C" & (cRow + 1))
Set rngArray(3) = Range("E" & myRow & ":E" & (cRow + 1))
Set rngArray(4) = Range("F" & myRow & ":F" & (cRow + 1))
For i = 1 To 4
Set mRng = rngArray(i)
mRng.Merge
With mRng
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Next i
myRow = cRow + 1
Exit For
End If
Next cRow
End If
Next myRow
Application.DisplayAlerts = True
End Sub

    son pas fou, élégant mais je l'ai testé et ça fonctionne 🙂 bonne chance

    • Je vous remercie beaucoup, Monsieur le Monshaw! qui a fait le tour et m'a sauvé beaucoup de temps.
    • mon plaisir, passer de l'aide 🙂
    InformationsquelleAutor Mr.Monshaw