[Résolu] Mettre en évidence des colonnes identiques

Qoods

XLDnaute Nouveau
Bonjour à tous,

J'ai un fichier Excel avec différentes colonnes dans lesquelles des "X" sont placés en fonction de la présence ou non d'un champ sur une page
Je voudrais que les pages ayant les mêmes champs soient colorées afin de pouvoir au final fusionner ces deux pages en une seule.


Voilà un exemple qui sera surement plus parlant :

Code:
CHAMPS    Page1    Page2    Page3    Page4    Page5    Page6    Page7
nom         X        X        X        X        X        X        X
prénom      X                 X        X        X
adresse              X                                   X
telfix      X                                   X
telmob                                 X                          X
proprio                                                           X

J'aimerai donc que la colonne Page1 et Page5 soient par exemple en verte, puis que Page2 et Page6 soient en bleu.

Merci d'avance les Excellents
 

vgendron

XLDnaute Barbatruc
:-D
l'idée est la suivante
pour colorer deux pages, il faut que TOUS les champs soient identiques..
les numéros (de 1 à 6 parce que il y a 6 champs) correpondent au nombre de champs identiques entre chaque page

ligne 9 (page1)
colonne C (page1) on compte le nombre de champs identiques.. ici.. forcément 6
colonne D (page2) il y a 3 champs identiques.....

ligne 10(page2)
colonneD (page2) ici forcément 6...
....

ensuite . la macro regarde la où il y a des 6 et colore les pages correspondantes..

la formule maintenant; en D9
SOMMEPROD((DECALER($B$2;;EQUIV($B9;$C$1:$I$1;0);6)=D$2:D$7)*1)

equiv: recherche B9 dans la zone C1:H1 --> ici 1: page 1, est la première
decaler(): renvoi les 6 champs de la page 1 (C2:C7)
(pour la page 3, ca renverrai E2:E7)

sommeprod (formule matricielle)
la partie Prod compare les élements de C2:C7 et D2:D7 un à un:
C2 avec D2 puis C3 avec D3......C7 D7: ca donne donc une matrice de vrai et faux
la partie Somme de cette fonction, compte le nombre de vrai
 

Qoods

XLDnaute Nouveau
Aaaaaah super ça saute aux yeux maintenant l'histoire des nombres. Ok !

Le soucis est que j'ai dans mon fichier non pas 7 pages mais 34 pages différentes. Il en va de même avec les champs, j'en ai 147 au lieu de 6.
J'ai simplement à changer les boucles dans la macro ?

EDIT : J'ai réussi à recopier le tableau intermédiaire sur mes 34 colonnes et 147 lignes. Comment puis-je modifier la macro ?
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour Qoods, vgendron,
Code:
Sub Compare()
Dim coul As Range, nlig&, ncol%, i%, P As Range, j%, k&
Set coul = [K2]
With [B1].CurrentRegion
  nlig = .Rows.Count
  ncol = .Columns.Count
  .Interior.ColorIndex = xlNone 'RAZ
  For i = 2 To ncol - 1
    Set P = Nothing
    For j = i + 1 To ncol
      For k = 2 To nlig
        If .Cells(k, i) <> .Cells(k, j) Then GoTo 1
      Next k
      Set P = Union(.Columns(i), .Columns(j), IIf(P Is Nothing, .Columns(i), P))
1   Next j
    If Not P Is Nothing Then
      P.Interior.Color = coul.Interior.Color
      Set coul = coul(2)
    End If
  Next i
End With
End Sub
Fichier joint.

A+
 

Pièces jointes

  • Compare(1).xlsm
    26.3 KB · Affichages: 77

vgendron

XLDnaute Barbatruc
Re

avec un code qui n'a pas besoin du tableau intermédiaire
j'ai commenté les lignes pour que tu vois le cheminement

Juste un point à changer, la coloration..
si j'utilise juste i en indexcolor, les différences de coloration ne se voient pas..

Code:
Sub associe2()
Idem = False
'récupère le nombre de page sur la ligne1
NbPages = Range("B1").End(xlToRight).Column - 2
'récupère le nombre de champs dans la colonne B
NbChamps = Range("B1").End(xlDown).Row - 1

'on set la zone contenant les X
Set Tabdata = Range("C2").Resize(NbChamps, NbPages)

'Tabdata.Select
'pour chaque page
For i = 1 To NbPages
    'on set les champs de la première page qui va servir à la comparaison
    Set Pagei = Tabdata.Item(1, i).Resize(NbChamps)
   
    'comparaison de la page i avec les pages suivantes
    For j = i + 1 To NbPages
        'on set les champs de la seconde page qui va servir à la comparaison
        Set Pagej = Tabdata.Item(1, j).Resize(NbChamps)
       
        'comparaison des champs un par un
        For k = 1 To NbChamps
            If Pagei.Item(k) <> Pagej.Item(k) Then
                Idem = False
                Exit For 'pas la peine de continuer la comparaison puisqu'au moins un champ est différent
            End If
        Next k
        If Idem = True Then
            MsgBox ("page " & i & "et page " & j & " sont identiques")
            Tabdata.Item(1, i).Offset(-1, 0).Interior.ColorIndex = i
            Tabdata.Item(1, j).Offset(-1, 0).Interior.ColorIndex = i
        End If
    'on reinitialise Idem à true
    Idem = True
    Next j
Next i
End Sub
 

vgendron

XLDnaute Barbatruc
bon. suffit d'ajouter 8 (pris au hasard)

If Idem = True Then
MsgBox ("page " & i & "et page " & j & " sont identiques")
Tabdata.Item(1, i).Offset(-1, 0).Interior.ColorIndex = i + 8
Tabdata.Item(1, j).Offset(-1, 0).Interior.ColorIndex = i + 8
End If
 

Qoods

XLDnaute Nouveau
Merci infiniment pour votre disponibilité, c'est cool ! :)

Je ne m'y connais pas du tout en macro, il faut juste que je la crée et que j'applique à un bouton sur lequel je dois cliquer ?

EDIT : J'ai réussi à exécuter la macro, mais certaines pages similaires ne sont pas de la même couleur. Est-ce lié au +8 ?
EDIT 2 : En enlevant le +8, différentes couleurs sont là et les pages identiques semblent correspondre. Je vérifie et j'edit :)
 
Dernière édition:

vgendron

XLDnaute Barbatruc
Bon. j'ai vu que chez moi aussi, ca buggait pour 3 colonnes identiques..
donc. correctif

Code:
Sub associe2()
Idem = False
'récupère le nombre de page sur la ligne1
NbPages = Range("B1").End(xlToRight).Column - 2
'récupère le nombre de champs dans la colonne B
NbChamps = Range("B1").End(xlDown).Row - 1

'on set la zone contenant les X
Set TabData = Range("C2").Resize(NbChamps, NbPages)

'Tabdata.Select
'pour chaque page
For i = 1 To NbPages
    If TabData.Item(1, i).Offset(-1, 0).Interior.ColorIndex = xlNone Then
        'on set les champs de la première page qui va servir à la comparaison
        Set Pagei = TabData.Item(1, i).Resize(NbChamps)
   
        'comparaison de la page i avec les pages suivantes
        For j = i + 1 To NbPages
            'on set les champs de la seconde page qui va servir à la comparaison
            Set Pagej = TabData.Item(1, j).Resize(NbChamps)
       
            'comparaison des champs un par un
            For k = 1 To NbChamps
                If Pagei.Item(k) <> Pagej.Item(k) Then
                    Idem = False
                    Exit For 'pas la peine de continuer la comparaison puisqu'au moins un champ est différent
                End If
            Next k
            If Idem = True Then
                MsgBox ("page " & i & "et page " & j & " sont identiques")
                TabData.Item(1, i).Offset(-1, 0).Interior.ColorIndex = i + 8
                TabData.Item(1, j).Offset(-1, 0).Interior.ColorIndex = i + 8
            End If
            'on reinitialise Idem à true
            Idem = True
        Next j
    End If
Next i
End Sub
 

job75

XLDnaute Barbatruc
Re,
Salut job75, merci pour ton aide :)

Ta macro ne marche pas dans TOUS les cas. Elle marche niquel avec 2 colonnes mais quand 3 sont identiques, les couleurs diffèrent.
Oui en effet il faut sauter les colonnes déjà colorées :
Code:
Sub Compare()
Dim coul As Range, nlig&, ncol%, i%, P As Range, j%, k&
Set coul = [K2]
With [B1].CurrentRegion
  nlig = .Rows.Count
  ncol = .Columns.Count
  .Interior.ColorIndex = xlNone 'RAZ
  For i = 2 To ncol - 1
    If .Cells(1, i).Interior.ColorIndex <> xlNone Then GoTo 2
    Set P = Nothing
    For j = i + 1 To ncol
      If .Cells(1, j).Interior.ColorIndex <> xlNone Then GoTo 1
      For k = 2 To nlig
        If .Cells(k, i) <> .Cells(k, j) Then GoTo 1
      Next k
      Set P = Union(.Columns(i), .Columns(j), IIf(P Is Nothing, .Columns(i), P))
1   Next j
    If Not P Is Nothing Then
      P.Interior.Color = coul.Interior.Color
      Set coul = coul(2)
    End If
2 Next i
End With
End Sub
Fichier (2).

A+
 

Pièces jointes

  • Compare(2).xlsm
    26.3 KB · Affichages: 67

vgendron

XLDnaute Barbatruc
pour la macro

ouvrir editeur VBA: Alt +F11
à gauche dans l'explorateur; cliquer sur le nom du fichier
clic droit, ajouter module standard
dans la fenetre à droite: coller le code

Retour dans excel (2007 pour moi)
onglet développeur:
inserer - bouton
et y affecter la macro

voir PJ:
 

Pièces jointes

  • Qoods.xlsm
    22.3 KB · Affichages: 76

Qoods

XLDnaute Nouveau
Bon. j'ai vu que chez moi aussi, ca buggait pour 3 colonnes identiques..
donc. correctif

Code:
Sub associe2()
Idem = False
'récupère le nombre de page sur la ligne1
NbPages = Range("B1").End(xlToRight).Column - 2
'récupère le nombre de champs dans la colonne B
NbChamps = Range("B1").End(xlDown).Row - 1

'on set la zone contenant les X
Set TabData = Range("C2").Resize(NbChamps, NbPages)

'Tabdata.Select
'pour chaque page
For i = 1 To NbPages
    If TabData.Item(1, i).Offset(-1, 0).Interior.ColorIndex = xlNone Then
        'on set les champs de la première page qui va servir à la comparaison
        Set Pagei = TabData.Item(1, i).Resize(NbChamps)
  
        'comparaison de la page i avec les pages suivantes
        For j = i + 1 To NbPages
            'on set les champs de la seconde page qui va servir à la comparaison
            Set Pagej = TabData.Item(1, j).Resize(NbChamps)
      
            'comparaison des champs un par un
            For k = 1 To NbChamps
                If Pagei.Item(k) <> Pagej.Item(k) Then
                    Idem = False
                    Exit For 'pas la peine de continuer la comparaison puisqu'au moins un champ est différent
                End If
            Next k
            If Idem = True Then
                MsgBox ("page " & i & "et page " & j & " sont identiques")
                TabData.Item(1, i).Offset(-1, 0).Interior.ColorIndex = i + 8
                TabData.Item(1, j).Offset(-1, 0).Interior.ColorIndex = i + 8
            End If
            'on reinitialise Idem à true
            Idem = True
        Next j
    End If
Next i
End Sub

Chez moi, j'ai ma liste de CHAMPS en colonne A et toutes mes pages en colonne B, C, D ... AI
Je crois que je dois modifier le corps de la macro non ?
 

Qoods

XLDnaute Nouveau
Re,

Oui en effet il faut sauter les colonnes déjà colorées :
Code:
Sub Compare()
Dim coul As Range, nlig&, ncol%, i%, P As Range, j%, k&
Set coul = [K2]
With [B1].CurrentRegion
  nlig = .Rows.Count
  ncol = .Columns.Count
  .Interior.ColorIndex = xlNone 'RAZ
  For i = 2 To ncol - 1
    If .Cells(1, i).Interior.ColorIndex <> xlNone Then GoTo 2
    Set P = Nothing
    For j = i + 1 To ncol
      If .Cells(1, j).Interior.ColorIndex <> xlNone Then GoTo 1
      For k = 2 To nlig
        If .Cells(k, i) <> .Cells(k, j) Then GoTo 1
      Next k
      Set P = Union(.Columns(i), .Columns(j), IIf(P Is Nothing, .Columns(i), P))
1   Next j
    If Not P Is Nothing Then
      P.Interior.Color = coul.Interior.Color
      Set coul = coul(2)
    End If
2 Next i
End With
End Sub
Fichier (2).

A+

Merci infiniment, c'est génial !
 

Discussions similaires

Statistiques des forums

Discussions
311 715
Messages
2 081 822
Membres
101 822
dernier inscrit
holale