Mise en loop d'une macro de fusion

[loubar69]

Bonjour à tous !

Alors, je suis face à un petit soucis que je ne parvient pas à résoudre...

Je vous explique, j'ai un document d'historique de conversation sms, j'ai un peu modifier le document sortit du téléphone pour lui créer trois colonnes principales (qui sont les colonnes E, F et G). J'ai mis les messages dans les cases de la colonne F (du texte donc). J'ai un autre colonne (J) dans laquelle j'ai soit la valeur "RCV" (reçu) soit la valeur "SNT". Voilà pour la situation.

Mon soucis est que je voudrais que sur une ligne où j'ai la valeur "SNT" en J, la case en F fusionne avec la case vide en E. Et que sur une ligne où j'ai la valeur "RCV" en J, la case F fusionne avec la case vide en G.

J'ai trouvé un bout de code qui me fait ça ligne par ligne (enfin une des deux conditions à la fois, mais au pire je lancerais deux macros ça ne me dérange pas...) :

(exemple pour la ligne 1)

Sub test()
Range("E1:F1").UnMerge
If [J1] = "SNT" Then
    With Range("E1:F1")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .MergeCells = True
    End With
End If
End Sub

Là ça fonctionne sur la ligne 1, pas de soucis, la case J contient "SNT" donc la case F fusionne bien avec la case E.

Par contre je voudrais que la marco se loop toute seule sur toutes les lignes du tableau sinon, elle n'a aucun intérêt pour moi... (j'ai dans les 50 000 lignes au total... >< )

J'ai déjà fait pas mal de tentatives, mais débutant avec les vba, toutes se sont soldées par des échecs...


En espérant que vous pourrez m'aider !


Merci par avance !



à bientôt,


loubar

 

[ROGER2327]

Re : Mise en loop d'une macro de fusion

Re...

Je ne comprends pas...

Je suis désolé, je suis débutant avec les vba et là je ne saisis pas ce que je dois faire et garder ou remplacer dans ce code...

(...)

Il n'y a pas à être désolé : on est bien obligé de débuter !

Si la solution vous convient et que vous conservez le déclenchement de la procédure par un double-clic sur l'entête d'une des colonnes F ou J, il n'y a qu'une chose à faire : copier sans rien modifier le code de la feuille Feuille1 dans le module Worksheet correspondant à la feuille que vous voulez traiter.

Rappel du code que j'ai légèrement modifié :​

Private Sub toto(r, c, d, Ref)
Dim i&, h#

    Application.ScreenUpdating = 0

    i = Range(Cells(r, d), Cells(Rows.Count, d).End(xlUp).Offset(1)).Rows.Count
    With Range(Cells(r, d - 1), Cells(Rows.Count, d - 1).End(xlUp).Offset(1)).Rows: i = IIf(i < .Count, .Count, i)
        .Resize(i, 3).UnMerge
        With Application: .EnableEvents = 0: .Calculation = -4135: End With
        For i = 1 To i
            With .Cells(i)
                If Not IsEmpty(.Value) Then .Cut Destination:=.Offset(, 1)
            End With
        Next
        With Application: .Calculation = -4105: .EnableEvents = 1: End With
        With .Resize(i, 3): .Interior.Color = RGB(255, 255, 204): .Rows.EntireRow.AutoFit: End With
    End With


    With Range(Cells(r, c), Cells(Rows.Count, c).End(xlUp)).Rows: i = IIf(i < .Count, .Count, i) - 1: End With

    For i = 0 To i
        With Cells(r, d).Offset(i)
            Select Case Cells(r, c).Offset(i).Value
            Case Ref(0): With .Resize(1, 2): .Interior.Color = RGB(192, 240, 64): .Merge: End With
            Case Ref(1): h = .RowHeight: With .Offset(, -1).Resize(1, 2): .Interior.Color = RGB(240, 201, 224): .Merge: .RowHeight = h: End With
            End Select
        End With
    Next

    Application.ScreenUpdating = 1

End Sub



Private Sub Worksheet_BeforeDoubleClick(ByVal Cible As Range, Contremander As Boolean)
Dim c&, d&, r&
    r = 2                       'Première ligne de données

    c = Columns("J").Column     'Colonne de clef

    d = Columns("F").Column     'Colonne à traiter

    If Cible.Row = r + (r > 1) And Cible.Column = c Or Cible.Column = d Then toto r, c, d, Array("RCV", "SNT"): Contremander = True
End Sub

Par contre :

• Si dans votre feuille, les données sont disposées autrement, il vous faut aussi adapter ces trois lignes :

    r = 2                       'Première ligne de données

    c = Columns("J").Column     'Colonne de clef

    d = Columns("F").Column     'Colonne à traiter
'

Aucune modification n'est à faire dans la procédure toto.

• Si vous ne voulez pas déclencher la procédure par un double-clic sur l'entête d'une des colonnes F ou J, mais que vous préférez l'exécuter par un appel direct, vous remplacerez la procédure Worksheet_BeforeDoubleClick par celle-là :

Sub tata()
Dim c&, d&, r&
    r = 2                       'Première ligne de données

    c = Columns("J").Column     'Colonne de clef

    d = Columns("F").Column     'Colonne à traiter

    toto r, c, d, Array("RCV", "SNT")
End Sub

Toujours aucune modification à faire dans la procédure toto.

• Si vous voulez utiliser un bouton, il suffit de lui affecter la procédure tata.
  
  
  
• Si vous voulez régler les couleurs des colonnes E:G, il faut modifier les trois instructions
  
  
  .Interior.Color = RGB(r, g, b): ​
  
  dans le code de la procédure toto.

Une remarque : pour traiter 50 000 lignes, prévoir un peu de temps...
(... environ trois minutes et demie sur ma machine...)


En pièce jointe, le classeur corrigé.
​

ROGER2327
#6882

Jeudi 5 Haha 141 (Sainte Belgique, nourrice - fête Suprême Quarte)
19 Vendémiaire An CCXXII, 0,4772h - tournesol
2013-W41-4T01:08:43Z