Fusion sous condition

Version imprimable

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:

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.

27/12/2012, 17h56
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:

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

1 pièce(s) jointe(s)

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:

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.

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:

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:

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

28/12/2012, 11h48
hislop

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