Formule ou macro Résolu

Question

Bonjour,

Voilà mon petit souci j'aurais souhaité que lorsque je choisis "nouveau prix" dans la cellule B5 et que par la suite dans la cellule B6 je choisis "Même tarif ou Promotion" qu'il fussionne les cellules D5 à D6. Si je choisis encore "Même tarif ou promotion qu'il me la fusionne de D5 à D7 et ainsi de suite. Il ne fusionne pas les montants uniquement s'il s'agit d'un nouveau client. Ca devrait donné ca! :-) Je serai vraiment reconnaissante à la personne qui pourra m'aider.

Je sais que je peux le faire moi-même mais si c'était automatiser ce serait vraiment pratique car il y a beaucoup de données et j'oublie quelquefois de fusionner les cellules et des les additionner.

https://www.cjoint.com/?jEwiAkISW2

:-) Help

michel_m · Answer

Bonjour,
regarde si cette macro te convient:

Option Explicit
Const dep As Byte = 5 'ligne départ tableau
Const texto As String = "nouveau pix" ' texte séparateur

Sub fusionner_cellule()
Dim derlig As Long, nbre As Long, lig As Long, cptr As Long
Dim tablo

'initialisation
derlig = Range("B65536").End(xlUp).Row
nbre = Application.CountIf(Range(Cells(dep, 2), Cells(derlig, 2)), texto)
Range(Cells(dep, 8), Cells(derlig, 9)).Clear
ReDim tablo(nbre)

'collecte les numéros des lignes comportant texto
lig = dep - 1
For cptr = 1 To nbre
    tablo(cptr - 1) = Columns(2).Find(texto, Cells(lig, 2)).Row
    lig = tablo(cptr - 1)
Next
tablo(cptr - 1) = derlig + 1
'restitue
For cptr = 1 To UBound(tablo)
    With Range(Cells(tablo(cptr - 1), 8), Cells(tablo(cptr) - 1, 8))
        .Merge 'fusionne les cellules
        .HorizontalAlignment = xlCenter 'présentation
        .VerticalAlignment = xlCenter 'présentation
        .Borders.Weight = xlThin  'présentation
        .Value = Application.Sum(Range(Cells(tablo(cptr - 1), 4), Cells(tablo(cptr) - 1, 4))) 'somme nouveau prix
    End With
Next

End Sub


tite demo:
https://www.cjoint.com/?kbkrFICjXB

michel_m · Answer

Il faut que tu relances la macro...
les cellules fusionnées sont détruites au départ dans le paragraphe initialisation par cette instruction:
Range(Cells(dep, 8), Cells(derlig, 8)).Clear

C'est que le tableau est vraiment très grand 
Tu aurais pu le préciser AVANT: le raisonnement est souvent différent suivant le nombre de lignes prévisible (très grand est subjectif et ne veut rien dire: 1000 ou 10000 ou 50000 lignes est un renseignement exploitable ...)
Ainsi, il faut ajouter une instruction figeant le défilement de l'écran:rapidité et confort
Application.ScreenUpdating = False

donc le groupe initialisation de vient celui-ci à copier coller à la place (accès VBA: Alt+F11)

'initialisation
derlig = Range("B65536").End(xlUp).Row
nbre = Application.CountIf(Range(Cells(dep, 2), Cells(derlig, 2)), texto)
Application.ScreenUpdating = False
Range(Cells(dep, 8), Cells(derlig, 8)).Clear
ReDim tablo(nbre)

michel_m · Answer

bonjour,
si, chez moi ca défusionne; je teste toujours avant de fournir une réponse

ci dessous nouvelle macro pour "un tableau très grand " et qui recopie les données colonnes B et D (ce n'était pas précisé dans ta demande et pourrait être fait par formule si pas "tableau très grand" )

Option Explicit
Const dep As Byte = 5 'ligne départ tableau
Const texto As String = "nouveau pix" ' texte séparateur

Sub fusionner_cellule()
Dim derlig As Long, nbre As Long, lig As Long, cptr As Long
Dim tablo

'initialisation
derlig = Range("B65536").End(xlUp).Row
Application.ScreenUpdating = False 'fige le défilement de l'écran
Range(Cells(dep, 6), Cells(65535, 8)).Clear 'défusionne col H et nettoie col F, G,H
nbre = Application.CountIf(Range(Cells(dep, 2), Cells(derlig, 2)), texto)
ReDim tablo(nbre)

'collecte les numéros des lignes comportant texto
lig = dep - 1
For cptr = 1 To nbre
    tablo(cptr - 1) = Columns(2).Find(texto, Cells(lig, 2)).Row
    lig = tablo(cptr - 1)
Next
tablo(cptr - 1) = derlig + 1
'restitue
For cptr = 1 To UBound(tablo)
    With Range(Cells(tablo(cptr - 1), 8), Cells(tablo(cptr) - 1, 8))
        .Merge 'fusionne les cellules
        .Value = Application.Sum(Range(Cells(tablo(cptr - 1), 4), Cells(tablo(cptr) - 1, 4))) 'somme nouveau prix
    End With
Next

'recopie les nouvelles données
Range(Cells(dep, 6), Cells(derlig, 6)) = Range(Cells(dep, 2), Cells(derlig, 2)).Value
Range(Cells(dep, 7), Cells(derlig, 7)) = Range(Cells(dep, 4), Cells(derlig, 4)).Value

' met en forme le tableau
With Range(Cells(dep, 6), Cells(derlig, 8))
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Borders.Weight = xlThin
End With

End Sub

michel_m · Answer

C'est possible mais ca me fait refaire pratiquement toute la procédure, alors pitié!

Formule ou macro

4 réponses

Discussions similaires

Newsletters