Macro pour fusion de cellules

Salut le forum

Bon à mon tour de demander un peu d'aide, je ne dois pas avoir la tête à "macroter" aujourd'hui.

Le fichier : Macro_Fusion.xls

A vous relire

Mytå

P.S. C'est pour finaliser : Cette ficelle

Salut Mytå,

Une petite bricole qui devrait marcher...

J'efface des contenus pour éviter le message : "La sélection contient plusieurs valeurs. La fusion des cellules ne conservera que les données de la cellule supérieure gauche"

Peut-être connaissez-vous un moyen d'éviter ce message pendant la macro, ce qui serait plus "propre"

Sub fusion()
Dim lig As Byte, i As Byte, x As Byte, n As Byte
x = Range("C3").End(xlToRight).Column

For lig = 3 To 5
n = 3
For i = 4 To x + 1
If Cells(lig, i) <> Cells(lig, i - 1) Then
Range(Cells(lig, n + 1), Cells(lig, i - 1)).ClearContents
With Range(Cells(lig, n), Cells(lig, i - 1))
.MergeCells = True
.HorizontalAlignment = xlCenter
End With
n = i
End If
Next i
Next lig

End Sub

Pas trop cherché le rapport avec l'autre ficelle, un peu fatigué ce soir ...

bonjours sylvain, myta,

Je n'ai pas réussi à fire fonctionner la macro à sylvain ? pas trop cherché non plus, car je venais de finaliser sur une autre base :

Sub Macro1()
Dim i%, j%, k%, z$
For i = 3 To 5
  k = 3
  Do While Cells(i, k).Value <> ""
    z = Cells(i, k).Value
    If Cells(i, k + j + 1).Value = z Then
      j = j + 1
    Else
      With Cells(i, k).Offset(7).Resize(, j + 1)
        .HorizontalAlignment = xlCenter
        .MergeCells = True
      End With
      With Cells(i, k).Offset(7).Resize(, j + 1).Font
        .Name = "Arial"
        .Bold = True
        .Size = 18
      End With
      Cells(i, k).Offset(7) = z
      k = k + j + 1
      j = 0
    End If
  Loop
Next
End Sub

je n'ai pas cherché non plus le rapport avec l'autre ficelle.

A+

Re le forum

Voila la situation complète, je dois fusionner les cellules

Mes macros demandent amélioration, j'ai fait vite mais c'est la base du fichier

C'est la feuille Etiquettes qui doit avoir des fusions de cellules.

https://www.excel-pratique.com/~files/doc/Tournee_macro.xls

Mytå

re...

je t'ai refais la même revue et corrigée à la lumière de ce dernier fichier bien plus explicite.

Sub fusion()
Dim i%, j%, k%, z$
Application.DisplayAlerts = False
For i = 3 To Range("B65536").End(3).Row + 2
  k = 3
  Do While k < 30
    z = Cells(i, k).Value
    If Cells(i, k + j + 1).Value = z And k + j + 1 < 30 Then
      j = j + 1
    Else
      Cells(i, k).Resize(, j + 1).MergeCells = True
      Cells(i, k) = z
      k = k + j + 1
      j = 0
    End If
  Loop
Next
End Sub

ça devrait faire le joint, non ?

A+

l'un des problème est qu'une grosse case doit faire 27 cm soit 27 séparations de 1 ou autres, et excel doit calculer pour que justement chaque case atteigne bien les 27. Au départ il a fait des cases de 3 ou 4, pour atteindre ces 27, et j'ai du réajuster en fonction de la taille de chaques petites cases, vu qu'il ne connait pas la quantité de courrier recu par les clients.

Voilà, si ça peut vous aider...

IOULA

Bonsoir, Mytå

une autre solution, avec ce code :

Sub fusion()
Application.DisplayAlerts = False
Dim MesCels As Object, DerCol As Byte
Dim Lig As Byte, i As Byte, Nb As Byte
Set MesCels = CreateObject("Scripting.Dictionary")
DerCol = [IV3].End(xlToLeft).Column
For Lig = 3 To 5
    For i = 3 To DerCol
        If Not MesCels.Exists(Cells(Lig, i).Value) Then MesCels.Add Cells(Lig, i).Value, i
    Next i
    temp = MesCels.items: temp2 = MesCels.keys
    For i = LBound(temp) To UBound(temp)
        Nb = Application.CountIf(Range(Cells(Lig, 3), Cells(Lig, DerCol)), temp2(i))
        Cells(Lig, temp(i)).Resize(1, Nb).MergeCells = True
    Next i
    MesCels.RemoveAll
Next Lig
End Sub

Merci le forum

La deuxième macro de Galopin fait le travail.

Mytå