Discussion :

[hislop]

Bonjour,

Je découvre le VB, et ce forum par la même occasion, et je viens vers vous pour un petit problème.
Pour résumer cela rapidement, je souhaite fusionner deux cellules B(x) et B(x+1) si B(x)=B(x+1) et A(x)=A(x+1).

J'ai un code qui gère la première condition, mais je n'arrive pas à prendre en compte la deuxième. Voici le code en question :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub FusionBis()
    Dim n As Integer
    Dim m As Integer
    Dim colonne As String
    n = InputBox("Nombre de lignes ?")
    m = InputBox("Nombre de modalités ?")
    m = m + 2
    colonne = ConvertToLetter(m)
    For Each c In Worksheets("Exemple1").Range("B2", Cells(2, colonne))
    c.Activate
    Application.DisplayAlerts = False
    Départ = ActiveCell.Address
    Do While ActiveCell.Row < n + 1
    If (ActiveCell <> ActiveCell.Offset(1, 0)) And (ActiveCell.Offset(0, -1) <> ActiveCell.Offset(1, -1)) Then
    Range(Départ, ActiveCell.Address).Merge
    Départ = ActiveCell.Offset(1, 0).Address
    End If
    ActiveCell.Offset(1, 0).Activate
    Loop
    Next
End Sub

Sans la condition en rouge, le code exécute bien la fusion si une cellule est égale à celle du dessous. En ajoutant la seconde condition, les résultats sont totalement faux.

Quelqu'un a-t-il une solution / correction pour ajouter la 2ème condition ?

Par avance, merci.

[tedo01]

Bonjour,

Pour inverser une condition faite de ET, il faut utiliser le OU.
Par exemple, NON (A ET B) = NON(A) OU NON(B).
Dans ton cas, la condition du merge dans le while est Non(B(x)=B(x+1) et A(x)=A(x+1)), qu'il faut donc coder avec un Or :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If (ActiveCell <> ActiveCell.Offset(1, 0)) Or (ActiveCell.Offset(0, -1) <> ActiveCell.Offset(1, -1)) Then

[hislop]

Merci pour votre réponse.

La modification en "Or" ne résout pas mon problème.
Les cellules possédant des cellules gauches identiques ne fusionnent plus entre elles.

Un fichier excel pour exemple serait peut-être utile pour illustrer ma demande ?

J'ai joint un exemple, sur lequel exécuter la macro. Le nombre de lignes demandé est ici 14, et le nombre de modalités 5.
En ajoutant préalablement ce bout de code, pour transformer un chiffre en colonne excel :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Function ConvertToLetter(iCol As Integer) As String
   Dim iAlpha As Integer
   Dim iRemainder As Integer
   iAlpha = Int(iCol / 27)
   iRemainder = iCol - (iAlpha * 26)
   If iAlpha > 0 Then
      ConvertToLetter = Chr(iAlpha + 64)
   End If
   If iRemainder > 0 Then
      ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
   End If
End Function

Merci.

[tedo01]

Bonjour,

En plus du Or à la place du And, il fallait inverser l'ordre de traitement des colonne. En effet, une fois la première colonne fusionnée, la comparaison ligne à ligne dans le parcours de la deuxième colonne ne fonctionnait plus.
Du coup, le For Each doit être remplacé car il ne permet pas de déterminer l'ordre de balayage.

Voici ma proposition de code. J'en ai profité pour supprimer les Activate qui n'apportent rien et rendent l'exécution plus lourde :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub FusionBis()
    Dim n As Integer
    Dim m As Integer
 
    Dim intCol As Integer
    Dim intLigneBase As Integer
    Dim intLigne As Integer
    Dim objWS As Worksheet
 
    Set objWS = Worksheets("Exemple1")
 
    n = InputBox("Nombre de lignes ?")
    m = InputBox("Nombre de modalités ?")
    Application.DisplayAlerts = False
 
    For intCol = m + 1 To 2 Step -1
        intLigne = 2
        intLigneBase = 2
        Do While intLigne < n + 1
            If objWS.Cells(intLigne, intCol).Value <> objWS.Cells(intLigne + 1, intCol).Value Or objWS.Cells(intLigne, intCol - 1) <> objWS.Cells(intLigne + 1, intCol - 1) Then
                If intLigne <> intLigneBase Then
                    objWS.Range(objWS.Cells(intLigneBase, intCol).Address, objWS.Cells(intLigne, intCol).Address).Merge
                End If
                intLigneBase = intLigne + 1
            End If
            intLigne = intLigne + 1
        Loop
    Next intCol
    Application.DisplayAlerts = True
 
End Sub

Petit bonus, une fonction ConvertToLetter plus légère (elle n'est plus utilisée dans le code que je propose, mais ça peut servir ):

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
 
Public Function ConvertToLetter(iCol As Integer) As String
Dim strRef As String
    strRef = Cells(1, iCol).Address(True, False, xlA1)
    ConvertToLetter = Mid(strRef, 1, InStr(strRef, "$") - 1)
End Function

[hislop]

Merci beaucoup pour cette réponse, c'est parfait