Fusionner doublons VBA

bonjour j'espere que vous allez bien .

j'ai un probleme de doublons dans mon fichier excel

je voudrias fussioner les cellules doublons par collonnes par exemple collonne 1 ,2,3 ...

et des collones que je veux pas les fusionner psk ils contiennent les codesn client et la quantité qui sont colloriser en jaune dans mon fichier joint

si il y'a une proposition ça serait bien et merci .

Bonjour,

Merci de nous donner un aperçu du résultat escompté.

Cdlt.

oui pardon voila mon fichier j'ai deja fait une petite macro mais il faut a chaque fois selecionner une collonne vous la trouvé dans le fichier joint

Sub Fusion_Cellules()

Dim cel As Range

Dim i As Integer

Dim c As Integer

With Selection

If .Rows.Count > 1 And .Columns.Count > 1 Then

MsgBox ("Vous ne pouvez pas sélectionner SIMULTANEMENT :" & Chr(13) _

& Chr(13) & " Plusieurs Lignes" _

& Chr(13) & " ET" _

& Chr(13) & " Plusieurs Colonnes")

Exit Sub

Else

For Each cel In .Cells

If LCase(cel.Text) <> "" Then

i = 0

Application.DisplayAlerts = False

If .Columns.Count = 1 Then

Do While cel.Offset(i, 0).Text = cel.Offset(i + 1, 0).Text

i = i + 1

Loop

With Range(cel, cel.Offset(i, 0))

.VerticalAlignment = xlTop

.MergeCells = True

End With

Else

Do While cel.Offset(0, i).Text = cel.Offset(0, i + 1).Text

i = i + 1

Loop

Application.DisplayAlerts = False

With Range(cel, cel.Offset(0, i))

.MergeCells = True

End With

End If

Application.DisplayAlerts = True

End If

Next cel

End If

End With

End Sub

Re,

je ne connais pas l'objectif, mais ! ...

Cdlt.

merci pour ta reponse mais je veux quelque chose d'automatique en code vba .

Bonjour,

Une procédure VBA, okay, mais est ce que le résultat donné correspond à tes attentes ?

Il y a une règle que l'on doit s'efforcer de respecter avec Excel : Ne pas fusionner des cellules !...

Cdlt.

Bonjour Jean-Eric, anouar1990

On se base sur quelle colonne pour déterminer les dits "doublons"

Un essai pour visualiser la problèmatique

Option Explicit
Sub test()
Dim r As Range, couleurs, i As Long, j As Long, n As Byte
    couleurs = Array(43, 44)
    With Sheets(1)
        Set r = .Range("d2", .Cells(.Rows.Count, "d").End(xlUp))
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        For i = 1 To r.Count
            j = 1
            Do Until r(i) <> r(i).Cells(j)
                j = j + 1
            Loop
            With .Range(r(i), r(i).Cells(j - 1))
                If n = 2 Then n = 0
                .Interior.ColorIndex = couleurs(n)
                n = n + 1
                '            .Merge
                '            .VerticalAlignment = xlCenter
            End With
            i = i + j - 2
        Next i
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End With
End Sub

klin89

Re anouar1990,

Notre ami n'a pas l'air de vouloir se manifester

A voir pour l'exercice

Option Explicit
Sub test()
Dim r As Range, i As Long, j As Long, col As Byte
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Sheets(1)
        For col = 1 To 6
            Set r = .Range(.Cells(2, col), .Cells(.Rows.Count, col).End(xlUp))
            For i = 1 To r.Count
                j = 1
                Do Until r(i) <> r(i).Cells(j)
                    j = j + 1
                Loop
                With Range(r(i), r(i).Cells(j - 1))
                    .Merge
                    .VerticalAlignment = xlCenter
                End With
                i = i + j - 2
            Next i
        Next col
    End With
    Set r = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

klin89