Rechercher des valeurs d'un tableau vers un autre

Résolu
Ecrelinf Messages postés 36 Statut Membre -  
pijaku Messages postés 13513 Date d'inscription   Statut Modérateur Dernière intervention   -
Bonjour à tous,

J'ai actuellement deux classeurs Excel: un ancien et un nouveau. Dans chacun de ces classeurs, il y a une feuille "Items" avec en A des matricules.
Je souhaiterais récupérer dans une nouvelle feuille, du nouveau classeur, nommé "New_items", les lignes dont le matricule apparaît dans le nouveau classeur mais pas dans l'ancien classeur. Pour ce faire, j'ai mis à ma sauce une macro récupérée sur un forum et voilà ce que ça donne : 
Sub Nouvelles_Refs()
'
' Nouvelles_Refs Macro
'
Dim NomAncien As String 'Nom de l'ancien fichier
Dim NomNouvo As String 'Nom du nouveau fichier
Dim C As Variant
Dim Ref As Variant
Dim nvlref As Long
nvlref = 2
NomNouvo = ThisWorkbook.Name
NomAncien = Workbooks(NomNouvo).Worksheets("Procedure").Range("B2").Value

Dim ligneAncien As Long 
ligneAncien = 3
'Compter le nombre de ligne de l'ancien fichier
While Workbooks(NomAncien).Worksheets("Items").Range("A" & ligneAncien) <> ""
    ligneAncien = ligneAncien + 1
Wend

Dim ligneNouvo As Long
ligneNouvo = 3
'compter le nombre de ligne du nouveau fichier
While Workbooks(NomNouvo).Worksheets("Items").Cells(ligneNouvo, 1) <> ""
    ligneNouvo = ligneNouvo + 1
Wend

For i = 3 To ligneNouvo - 1
    Ref = Range("A" & i).Value
    Set C = Nothing
    Set C = Workbooks(NomAncien).Worksheets("Items").Range("A3:A" & ligneAncien).Find(what:=Ref, LookAt:=xlWhole, MatchCase:=False)
        If C Is Nothing Then
            Workbooks(NomNouvo).Worksheets("Items").Rows(i).Copy
            Sheets("New_items").Select
            Rows(nvlref).Select
            ActiveSheet.Paste
            nvlref = nvlref + 1
            Sheets("Items").Range("A" & i).Calculate
        End If
Next i

'
End Sub

Voilà le problème est que malgré ma boucle for, la condition "if" ne marche qu'une seule fois (une seule ligne est copiée dans l'onglet "new items", cette seule ligne est en fait la première ligne repérée par la macro) alors que deux lignes devraient être copiées dans cette feuille "new_items".

Voilà, j'espère avoir été assez clair, si ce n'est pas le cas n'hésitez pas à me poser toutes les questions que vous pourrez avoir, et je suis désolé si le code est moche, mais je ne suis qu'un novice et je n'ai pas encore toutes les bonnes habitudes que vous pourriez avoir ^^

Merci d'avance,
Ecrelinf.

PS : vous trouverez les-dits fichiers en suivant les liens ci-dessous.
Ancien : https://www.cjoint.com/?0GwpGCWjWUP
Nouveau : https://www.cjoint.com/?0GwpHGKGyoq

5 réponses

  1.
    pijaku Messages postés 13513 Date d'inscription   Statut Modérateur Dernière intervention   2 773
     
    Salut,

    Grrrr!
    Je fais toujours cette même erreur de débutant sur les variables tableaux. Ça m'apprendra à ne pas tester...
    En fait, une variable tableau à deux dimensions (Tb(2, 3)), si l'on souhaite qu'elle soit dynamique, on ne peux que faire évoluer, incrémenter, la seconde dimension. C'est à dire que ceci : 
    Tb(i, 2)
    ne peut pas être. Par contre, 
    Tb(2, i)
    , oui!
    Ensuite, lors de la restitution de la variable tableau dans la feuille, afin de remettre les lignes en colonnes et inversement, il nous faudra utiliser 
    Application.Transpose
    .
    J'en ai profité pour corriger un petit bug dans le FindNext de la fin...
    Ne t'inquiète pas pour :
    Je suis en train de recopier le code et je me demandais si le fait d'utiliser la même variable IndTbNouvo danhs la ligne

    If Tb_Nouvo(IndTbNouvo, Col) <> Tb_Ancien(mesRef_Ancien(Tb_Nouvo(IndTbNouvo, 1)), Col) Then

    ne signifie pas que les références sont forcément placées à la même ligne ?
    Normalement, c'est bon comme ça!
    ou pas...
    On verra, c'est selon...
    Des fois ça marrrrche et desw fois ça marrrche pas... 

    Option Explicit

Sub Refs_modif()
'
' Refs_modif Macro
'
Dim Tb_Ancien(), Tb_Nouvo(), Tb_Out()
Dim mesRef_Ancien As Object
Dim Trouve As Range

Dim NomAncien As String, NomNouvo As String, firstAddress As String
Dim ligneAncien As Long, ligneNouvo As Long, IndTbNouvo As Long
Dim i As Long, j As Long, DLig As Long, Col As Byte

Dim Modif As Boolean

'--------------------- STOCKAGE DES DONNEES DANS LES VARIABLES ---------------------------
'je récupère les noms de mes deux fichiers
NomNouvo = ThisWorkbook.Name
NomAncien = Workbooks(NomNouvo).Worksheets("Procedure").Range("B2").Value

    '**** STOCKAGE DE TOUTES LES DONNEES DE L'ANCIEN CLASSEUR
With Workbooks(NomAncien).Worksheets("Items")
    'je compte le nombre de ligne dans mon ancien tableau
    ligneAncien = .Range("A" & Rows.Count).End(xlUp).Row
    'Stockage de toutes les données de Cells(1, 1) à Cells(ligneAncien, 53)
    Tb_Ancien = .Range(.Cells(1, 1), .Cells(ligneAncien, 53)).Value
    '********** STOCKAGE DE LA LISTE DES REFERENCES DE L'ANCIEN TABLEAU
    Set mesRef_Ancien = CreateObject("Scripting.Dictionary")
    For i = LBound(Tb_Ancien) To UBound(Tb_Ancien)
        mesRef_Ancien(Tb_Ancien(i, 1)) = i
    Next i
End With

    '**** STOCKAGE DE TOUTES LES DONNEES DU NOUVEAU CLASSEUR
With Workbooks(NomNouvo).Worksheets("Items")
'je compte le nombre de ligne dans mon nouveau tableau
    ligneNouvo = .Range("A" & Rows.Count).End(xlUp).Row
    'Stockage de toutes les données de Cells(1, 1) à Cells(ligneNouvo, 53)
    Tb_Nouvo = .Range(.Cells(1, 1), .Cells(ligneNouvo, 53)).Value
End With


'--------------------- TEST DES DONNEES ET REMPLISSAGE TABLEAU DE SORTIE : ---------------------------
'boucle sur les références du nouveau tableau
For IndTbNouvo = 1 To UBound(Tb_Nouvo, 1) '!!!!!!!!!!!!!!!! Si la feuille contient une ligne d'entête, commencer à 2
    Modif = False
    'Si elle existe dans les références de l'ancien
    If mesRef_Ancien.exists(Tb_Nouvo(IndTbNouvo, 1)) Then
        'On vérifie s'il y a eu des modifs dans les 53 colonnes :
        For Col = 2 To 53
            If Tb_Nouvo(IndTbNouvo, Col) <> Tb_Ancien(mesRef_Ancien(Tb_Nouvo(IndTbNouvo, 1)), Col) Then
                'on note qu'il y a eu modification sur cette ligne
                Modif = True
                'on repère la cellule modifiée
                Tb_Nouvo(IndTbNouvo, Col) = Tb_Nouvo(IndTbNouvo, Col) & " ¤ "
            End If
        Next Col
        'On stocke la ligne si elle a été modifiée :
        If Modif Then
            j = j + 1
            ReDim Preserve Tb_Out(1 To 53, 1 To j)
            For Col = 1 To 53
                Tb_Out(Col, j) = Tb_Nouvo(IndTbNouvo, Col)
            Next
        End If
    End If
Next IndTbNouvo

'--------------------- RESTITUTION DES DONNEES ---------------------------
With Workbooks(NomNouvo).Worksheets("Feuil4") 'A ADAPTER!!!
    .Cells.Clear        '!!!!!!!!!!!!!!!!!! SUPPRIME TOUTES LES CELLULES DE LA FEUILLE !!!!!!!!!!!!!!!!!!
    .Range("A2").Resize(UBound(Tb_Out, 2), 53) = Application.Transpose(Tb_Out)
End With

'--------------------- LE COLORIAGE DES CELLULES MODIFIEES ---------------------------
With Workbooks(NomNouvo).Worksheets("Feuil4") 'A ADAPTER!!!
    DLig = .Range("A" & Rows.Count).End(xlUp).Row
    With .Range("A1:BA" & DLig)
        Set Trouve = .Find(" ¤ ")
        If Not Trouve Is Nothing Then
            firstAddress = Trouve.Address
            Do
                'on efface le signe de repérage : ¤
                Trouve.Value = Left(Trouve.Value, Len(Trouve.Value) - 3)
                'on colorie en rouge
                Trouve.Interior.Color = 255
                'on cherche la suivante
                Set Trouve = .FindNext(Trouve)
                If Trouve Is Nothing Then Exit Do
            Loop While Trouve.Address <> firstAddress
        End If
    End With
    .Select
End With
End Sub


    Cordialement,
    Franck
    1
    1. Ecrelinf Messages postés 36 Statut Membre
       
      Merci Franck pour ton aide !
      Cependant il semblerait que le petit bug du code-qui-ne-veut-pas-s'afficher est revenu ... ^^
      Bonne journée !
      0
    2. pijaku Messages postés 13513 Date d'inscription   Statut Modérateur Dernière intervention   2 773
       
      Et là??? 
      Option Explicit

      Sub Refs_modif()
      '
      ' Refs_modif Macro
      '
      Dim Tb_Ancien(), Tb_Nouvo(), Tb_Out()
      Dim mesRef_Ancien As Object
      Dim Trouve As Range

      Dim NomAncien As String, NomNouvo As String, firstAddress As String
      Dim ligneAncien As Long, ligneNouvo As Long, IndTbNouvo As Long
      Dim i As Long, j As Long, DLig As Long, Col As Byte

      Dim Modif As Boolean

      '--------------------- STOCKAGE DES DONNEES DANS LES VARIABLES ---------------------------
      'je récupère les noms de mes deux fichiers
      NomNouvo = ThisWorkbook.Name
      NomAncien = Workbooks(NomNouvo).Worksheets("Procedure").Range("B2").Value

          '**** STOCKAGE DE TOUTES LES DONNEES DE L'ANCIEN CLASSEUR
      With Workbooks(NomAncien).Worksheets("Items")
          'je compte le nombre de ligne dans mon ancien tableau
          ligneAncien = .Range("A" & Rows.Count).End(xlUp).Row
          'Stockage de toutes les données de Cells(1, 1) à Cells(ligneAncien, 53)
          Tb_Ancien = .Range(.Cells(1, 1), .Cells(ligneAncien, 53)).Value
          '********** STOCKAGE DE LA LISTE DES REFERENCES DE L'ANCIEN TABLEAU
          Set mesRef_Ancien = CreateObject("Scripting.Dictionary")
          For i = LBound(Tb_Ancien) To UBound(Tb_Ancien)
              mesRef_Ancien(Tb_Ancien(i, 1)) = i
          Next i
      End With

          '**** STOCKAGE DE TOUTES LES DONNEES DU NOUVEAU CLASSEUR
      With Workbooks(NomNouvo).Worksheets("Items")
      'je compte le nombre de ligne dans mon nouveau tableau
          ligneNouvo = .Range("A" & Rows.Count).End(xlUp).Row
          'Stockage de toutes les données de Cells(1, 1) à Cells(ligneNouvo, 53)
          Tb_Nouvo = .Range(.Cells(1, 1), .Cells(ligneNouvo, 53)).Value
      End With


      '--------------------- TEST DES DONNEES ET REMPLISSAGE TABLEAU DE SORTIE : ---------------------------
      'boucle sur les références du nouveau tableau
      For IndTbNouvo = 1 To UBound(Tb_Nouvo, 1) '!!!!!!!!!!!!!!!! Si la feuille contient une ligne d'entête, commencer à 2
          Modif = False
          'Si elle existe dans les références de l'ancien
          If mesRef_Ancien.exists(Tb_Nouvo(IndTbNouvo, 1)) Then
              'On vérifie s'il y a eu des modifs dans les 53 colonnes :
              For Col = 2 To 53
                  If Tb_Nouvo(IndTbNouvo, Col) <> Tb_Ancien(mesRef_Ancien(Tb_Nouvo(IndTbNouvo, 1)), Col) Then
                      'on note qu'il y a eu modification sur cette ligne
                      Modif = True
                      'on repère la cellule modifiée
                      Tb_Nouvo(IndTbNouvo, Col) = Tb_Nouvo(IndTbNouvo, Col) & " ¤ "
                  End If
              Next Col
              'On stocke la ligne si elle a été modifiée :
              If Modif Then
                  j = j + 1
                  ReDim Preserve Tb_Out(1 To 53, 1 To j)
                  For Col = 1 To 53
                      Tb_Out(Col, j) = Tb_Nouvo(IndTbNouvo, Col)
                  Next
              End If
          End If
      Next IndTbNouvo

      '--------------------- RESTITUTION DES DONNEES ---------------------------
      With Workbooks(NomNouvo).Worksheets("Feuil4") 'A ADAPTER!!!
          .Cells.Clear        '!!!!!!!!!!!!!!!!!! SUPPRIME TOUTES LES CELLULES DE LA FEUILLE !!!!!!!!!!!!!!!!!!
          .Range("A2").Resize(UBound(Tb_Out, 2), 53) = Application.Transpose(Tb_Out)
      End With

      '--------------------- LE COLORIAGE DES CELLULES MODIFIEES ---------------------------
      With Workbooks(NomNouvo).Worksheets("Feuil4") 'A ADAPTER!!!
          DLig = .Range("A" & Rows.Count).End(xlUp).Row
          With .Range("A1:BA" & DLig)
              Set Trouve = .Find(" ¤ ")
              If Not Trouve Is Nothing Then
                  firstAddress = Trouve.Address
                  Do
                      'on efface le signe de repérage : ¤
                      Trouve.Value = Left(Trouve.Value, Len(Trouve.Value) - 3)
                      'on colorie en rouge
                      Trouve.Interior.Color = 255
                      'on cherche la suivante
                      Set Trouve = .FindNext(Trouve)
                      If Trouve Is Nothing Then Exit Do
                  Loop While Trouve.Address <> firstAddress
              End If
          End With
          .Select
      End With
      End Sub
      0
    3. pijaku Messages postés 13513 Date d'inscription   Statut Modérateur Dernière intervention   2 773
       
      En ce qui concerne le bug d'affichage du code, je pencherais pour une (énième) boulette de ton navigateur IE8.....
      A vérifier.
      0
    4. Ecrelinf Messages postés 36 Statut Membre
       
      Bonjour Franck,

      Merci pour ton aide, le code fonctionne presque entièrement chez moi ! ^^^
      En effet les cellules sont bien repérées et copiées, le seul problème c'est que la macro n'arrive pas à retrouver les cases ayant le signe de repérage " ¤ " et donc mes cases contiennent toujours le-dit signe et ne sont pas coloriées :/
      pourtant je ne vois rien qui cloche dans le code, je suis confus ^^'

      Je te renvoie les fichiers anciens et nouveaux si jamais tu réussis à trouver le petit truc qu'il me manque !

      Ancien : https://www.cjoint.com/?0GCj43DVtQF
      Nouveau : https://www.cjoint.com/?0GCj5ZsEACc

      Merci beaucoup,

      Ecrelinf
      0
    5. pijaku Messages postés 13513 Date d'inscription   Statut Modérateur Dernière intervention   2 773
       
      Bonjour,

      Je viens d'essayer avec tes deux fichiers. Résultat des cellules coloriées en rouge, sans ¤.....
      0
  2. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    Bonjour

    Dans la réalité, combien as tu de lignes (environ) dans tes classeurs ?
    les solutions possibles pourront être différentes suivant ce nombre...

    Le classeur ancien est il ouvert au lancement de la macro (apparemment oui, mais...) ?

    Michel
    0
    1. Ecrelinf Messages postés 36 Statut Membre
       
      oui oui le classeur ancien est ouvert au moment de la macro, j'ai trouvé une solution en passant pas mal de temps sur google et ça semble marcher avec peu de valeurs (mes tableaux font 8000 lignes donc à voir si ça fonctionne). Je poste la macro au cas où quelqu'un chercherait une solution : 

      'COMPARAISON DE 2 BD;REVU ET CORRIGÉ FLA 24.03.08
      'CRITÈRE DE COMPARAISON :ITEMS EN COLONNE A; À DÉFINIR
      'RÉCUPÉRATION DES ITEMS DIFFÉRENTS ENTRE SBD1 ET SBD2
      'UTILISATION DE LA MÉTHODE DIRECTE
      Sub BD1NonBD2()
      Dim C As Variant, X As Variant
      Dim Actuel&, Kl&, I&, Vcol&
      Dim Sbd1 As Worksheet, Sbd2 As Worksheet, Cible As Worksheet
      Application.Calculation = xlCalculationManual
      Application.ScreenUpdating = False
      Set Sbd1 = Feuil1
      Set Sbd2 = Feuil2
      'Vcol dernière colonne de la base
      Vcol = Feuil1.Cells.Find("*", [A1], -4123, , 1, 2).Column
      Actuel = 2: Kl = Sbd1.[A65000].End(xlUp).Row + 1
      Set Cible = Feuil5
      'Raz des traitements précédents
      Cible.Range("A1").Offset(1, 0).Resize(Kl, Vcol).ClearContents
      Sbd1.Range("A1").Offset(1, 0).Resize(Kl, Vcol).Interior.ColorIndex = xlNone
      'Traitement de la base 1
          For I = 2 To Kl
            X = Sbd1.Cells(I, 1)
          'optionnel pour les données numériques
          ' X = TrimZéro(Trim(Sbd1.Cells(I, 1)))
          ' Option xlWhole ou xlpart
            Set C = Sbd2.[A:A].Find(what:=X, LookAt:=xlWhole, MatchCase:=False)
            If C Is Nothing Then
           'pour récupérer les items identiques le code sera
           ' If not C Is Nothing Then
           'Copie de la zone source vers la feuille cible
               Cible.Cells(Actuel, 1).Resize(1, Vcol).Value = _
                 Sbd1.Cells(I, 1).Resize(1, Vcol).Value
           'indexation du compteur de ligne pour la copie
               Actuel = Actuel + 1
               Sbd1.Cells(I, 1).Interior.ColorIndex = 33
               Sbd1.Cells(I, 1).Calculate
            End If
          Next I
      Feuil5.Range("a1:e1").Value = Feuil1.Range("a1:e1").Value
      Application.GoTo reference:=Feuil5.Cells(2, 1), Scroll:=True
      Application.Calculation = xlCalculationAutomatic
      Set Sbd1 = Nothing:    Set Sbd2 = Nothing
      Set C = Nothing: Set Cible = Nothing
      End Sub

      Merci Michel.m ! Et bonne journée ;)
      0
    2. Ecrelinf Messages postés 36 Statut Membre
       
      Bonjour Michel_m,

      oui oui le classeur ancien est bien ouvert au lancement de la macro. J'ai trouvé une solution grâce à google qui fonctionne avec peu de valeurs (mes tableaux font approximativement 8000 lignes donc à voir si ça fonctionne ...) Je poste quand même le code au cas où quelqu'un en aurait besoin : 

      'COMPARAISON DE 2 BD;REVU ET CORRIGÉ FLA 24.03.08
      'CRITÈRE DE COMPARAISON :ITEMS EN COLONNE A; À DÉFINIR
      'RÉCUPÉRATION DES ITEMS DIFFÉRENTS ENTRE SBD1 ET SBD2
      'UTILISATION DE LA MÉTHODE DIRECTE
      Sub BD1NonBD2()
      Dim C As Variant, X As Variant
      Dim Actuel&, Kl&, I&, Vcol&
      Dim Sbd1 As Worksheet, Sbd2 As Worksheet, Cible As Worksheet
      Application.Calculation = xlCalculationManual
      Application.ScreenUpdating = False
      Set Sbd1 = Feuil1
      Set Sbd2 = Feuil2
      'Vcol dernière colonne de la base
      Vcol = Feuil1.Cells.Find("*", [A1], -4123, , 1, 2).Column
      Actuel = 2: Kl = Sbd1.[A65000].End(xlUp).Row + 1
      Set Cible = Feuil5
      'Raz des traitements précédents
      Cible.Range("A1").Offset(1, 0).Resize(Kl, Vcol).ClearContents
      Sbd1.Range("A1").Offset(1, 0).Resize(Kl, Vcol).Interior.ColorIndex = xlNone
      'Traitement de la base 1
          For I = 2 To Kl
            X = Sbd1.Cells(I, 1)
          'optionnel pour les données numériques
          ' X = TrimZéro(Trim(Sbd1.Cells(I, 1)))
          ' Option xlWhole ou xlpart
            Set C = Sbd2.[A:A].Find(what:=X, LookAt:=xlWhole, MatchCase:=False)
            If C Is Nothing Then
           'pour récupérer les items identiques le code sera
           ' If not C Is Nothing Then
           'Copie de la zone source vers la feuille cible
               Cible.Cells(Actuel, 1).Resize(1, Vcol).Value = _
                 Sbd1.Cells(I, 1).Resize(1, Vcol).Value
           'indexation du compteur de ligne pour la copie
               Actuel = Actuel + 1
               Sbd1.Cells(I, 1).Interior.ColorIndex = 33
               Sbd1.Cells(I, 1).Calculate
            End If
          Next I
      Feuil5.Range("a1:e1").Value = Feuil1.Range("a1:e1").Value
      Application.GoTo reference:=Feuil5.Cells(2, 1), Scroll:=True
      Application.Calculation = xlCalculationAutomatic
      Set Sbd1 = Nothing:    Set Sbd2 = Nothing
      Set C = Nothing: Set Cible = Nothing
      End Sub

      Merci quand même pour ton aide Michel_m (mais je planche sur une autre macro actuellement, alors ne t'en va pas trop loin ahah ^^)

      Bonne journée,
      Ecrelinf
      0
  3. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    Pourquoi faire un doublon ?
    https://forums.commentcamarche.net/forum/affich-30547876-comparer-deux-longues-lignes

    Abandon du suivi sur ces 2 postS
    0
    1. Ecrelinf Messages postés 36 Statut Membre
       
      Ce n'est pas un doublon, j'ai créé une autre discussion car je ne recherche plus la même chose ;) Celle ci est résolue.
      0
    2. pijaku Messages postés 13513 Date d'inscription   Statut Modérateur Dernière intervention   2 773
       
      mais je planche sur une autre macro actuellement, alors ne t'en va pas trop loin
      L'autre discussion est fermée car tout peut se faire sur celle-ci. Ce ne serait pas la première fois qu'un sujet évoluerait, loin s'en faut.
      Fin de la discussion sur doublon ou pas.

      Reprenez le fil du sujet ou vous en étiez, quitte à refaire un laïus complet sur ce que vous souhaitez faire...
      0
  4. Ecrelinf Messages postés 36 Statut Membre
     
    Bonjour Pijaku,

    Ce n'était pas vraiment un doublon, puisque je ne cherchais pas vraiment la même chose (même si au final on parle de la même macro ;))
    Cette macro a deux objectifs :

    1) Comparer un fichier et sa mise à jour, repérer les nouvelles références et copier ces références ainsi que toutes les données dans une nouvelle feuille (c'était l'objet de cette discussion mais le problème est résolu)

    2) Comparer un fichier et sa mise à jour, repérer les données qui ont été modifiées pour une même référence et copier les lignes modifiée dans un nouvel onglet (c'était l'objet de la nouvelle discussion ouverte, autant continuer ici c'est vrai, désolé pour ma gaffe je ne suis pas un habitué des forums).

    Concernant le deuxième point, Pijaku tu me parles de variable tableau, que je ne connais pas. Je vais de ce pas me renseigner un peu et je reviens vers toi ;)

    Cependant j'ai quand même commencé la macro évoquée dans l'autre discussion et j'ai un problème, ma boucle for ne se lance pas. Voici le code : 

    Sub Refs_modif()
    '
    ' Refs_modif Macro
    '
    Dim NomAncien As String
    Dim NomNouvo As String
    Dim a As Long
    Dim b As Long

    'je récupère les noms de mes deux fichiers
    NomNouvo = ThisWorkbook.Name
    NomAncien = Workbooks(NomNouvo).Worksheets("Procedure").Range("B2").Value

    'je compte le nombre de ligne dans mon ancien tableau 
    Dim ligneAncien As Long
    ligneAncien = 1
    While Workbooks(NomAncien).Worksheets("Items").Range("A" & ligneAncien) <> ""
        ligneAncien = ligneAncien + 1
    Wend

    'je compte le nombre de ligne dans mon nouveau tableau 
    Dim ligneNouvo As Long
    ligneNouvo = 1
    While Workbooks(NomNouvo).Worksheets("Items").Cells(ligneNouvo, 1) <> ""
        ligneNouvo = ligneNouvo + 1
    Wend

    'Je lance mes deux boucles for
    For a = 1 To ligneNouveau
        For b = 1 To ligneAncien
            'je repère les références identiques
               If Workbooks(NomNouvo).Sheets("Items").Range("A" & a).Value = _
               Workbooks(NomAncien).Sheets("Items").Range("A" & b).Value Then
                    'Les deux ifs qui suivent : comparer les données en B et C
                    'si les données diffèrent, je colorie mes cellule
                    'et ajoute un "1" en BB qui est mon repère pour pouvoir les coller
                    'dans une nouvelle feuille plus tard
                    If Workbooks(NomNouvo).Sheets("Items").Range("B" & a).Value <> _
                       Workbooks(NomAncien).Sheets("Items").Range("B" & b).Value Then
                       Workbooks(NomNouvo).Sheets("Items").Range("B" & a).Interrior.ColorIndex = 33
                       Workbooks(NomNouvo).Sheets("Items").Range("BB" & a).Value = "1"
                    End If
                    If Workbooks(NomNouvo).Sheets("Items").Range("C" & a).Value <> _
                       Workbooks(NomAncien).Sheets("Items").Range("C" & b).Value Then
                       Workbooks(NomNouvo).Sheets("Items").Range("C" & a).Interrior.ColorIndex = 33
                       Workbooks(NomNouvo).Sheets("Items").Range("BB" & a).Value = "1"
                    End If
            End If
        Next b
    Next a

    MsgBox a
    MsgBox b

    End Sub

    En effet, les msgbox a et b me renvoient a = 1 et b = 0 ...

    Même moi je me rends compte que je fais vraiment du bricolage, je fais avec les moyens du bord ... :/

    Merci d'avance pour votre aide,
    Ecrelinf
    0
    1. pijaku Messages postés 13513 Date d'inscription   Statut Modérateur Dernière intervention   2 773
       
      Connais tu les variables tableau?
      0
    2. Ecrelinf Messages postés 36 Statut Membre
       
      Pijaku, je me suis renseigné un peu sur les variables tableau, mais je ne vois pas trop comment les utiliser puisque mes références ne sont pas forcément sur les mêmes lignes d'un tableau à l'autre.
      Exemple :
      Je peux avoir la référence AB154 en ligne 14 sur le tableau Ancien et la même référence AB154 en ligne 45.
      0

  5. Vous n’avez pas trouvé la réponse que vous recherchez ?

    Posez votre question
  6. pijaku Messages postés 13513 Date d'inscription   Statut Modérateur Dernière intervention   2 773
     
    Voici mon "premier jet".
    Cela donne une macro relativement complexe, dis moi si c'est bien le résultat attendu...
    Attention à adapter ce qui doit l'être, notamment la feuille de "sortie"... Lis donc tous les commentaires de la macro... 

    Option Explicit

Sub Refs_modif()
'
' Refs_modif Macro
'
Dim Tb_Ancien(), Tb_Nouvo(), Tb_Out()
Dim mesRef_Ancien As Object
Dim Trouve As Range

Dim NomAncien As String, NomNouvo As String, firstAddress As String
Dim ligneAncien As Long, ligneNouvo As Long, IndTbNouvo As Long
Dim i As Long, j As Long, DLig As Long, Col As Byte

Dim Modif As Boolean

'--------------------- STOCKAGE DES DONNEES DANS LES VARIABLES ---------------------------
'je récupère les noms de mes deux fichiers
NomNouvo = ThisWorkbook.Name
NomAncien = Workbooks(NomNouvo).Worksheets("Procedure").Range("B2").Value

    '**** STOCKAGE DE TOUTES LES DONNEES DE L'ANCIEN CLASSEUR
With Workbooks(NomAncien).Worksheets("Items")
    'je compte le nombre de ligne dans mon ancien tableau
    ligneAncien = .Range("A" & Rows.Count).End(xlUp).Row
    'Stockage de toutes les données de Cells(1, 1) à Cells(ligneAncien, 53)
    Tb_Ancien = .Range(.Cells(1, 1), .Cells(ligneAncien, 53)).Value
    '********** STOCKAGE DE LA LISTE DES REFERENCES DE L'ANCIEN TABLEAU
    Set mesRef_Ancien = CreateObject("Scripting.Dictionary")
    For i = LBound(Tb_Ancien) To UBound(Tb_Ancien)
        mesRef_Ancien(Tb_Ancien(i, 1)) = i
    Next i
End With

    '**** STOCKAGE DE TOUTES LES DONNEES DU NOUVEAU CLASSEUR
With Workbooks(NomNouvo).Worksheets("Items")
'je compte le nombre de ligne dans mon nouveau tableau
    ligneNouvo = .Range("A" & Rows.Count).End(xlUp).Row
    'Stockage de toutes les données de Cells(1, 1) à Cells(ligneNouvo, 53)
    Tb_Nouvo = .Range(.Cells(1, 1), .Cells(ligneNouvo, 53)).Value
End With


'--------------------- TEST DES DONNEES ET REMPLISSAGE TABLEAU DE SORTIE : ---------------------------
'boucle sur les références du nouveau tableau
For IndTbNouvo = 1 To UBound(Tb_Nouvo, 1) '!!!!!!!!!!!!!!!! Si la feuille contient une ligne d'entête, commencer à 2
    Modif = False
    'Si elle existe dans les références de l'ancien
    If mesRef_Ancien.exists(Tb_Nouvo(IndTbNouvo, 1)) Then
        'On vérifie s'il y a eu des modifs dans les 53 colonnes :
        For Col = 2 To 53
            If Tb_Nouvo(IndTbNouvo, Col) <> Tb_Ancien(mesRef_Ancien(Tb_Nouvo(IndTbNouvo, 1)), Col) Then
                'on note qu'il y a eu modification sur cette ligne
                Modif = True
                'on repère la cellule modifiée
                Tb_Nouvo(IndTbNouvo, Col) = Tb_Nouvo(IndTbNouvo, Col) & " ¤ "
            End If
        Next Col
        'On stocke la ligne si elle a été modifiée :
        If Modif Then
            j = j + 1
            ReDim Preserve Tb_Out(1 To j, 1 To 53)
            For Col = 1 To 53
                Tb_Out(j, Col) = Tb_Nouvo(IndTbNouvo, Col)
            Next
        End If
    End If
Next IndTbNouvo

'--------------------- RESTITUTION DES DONNEES ---------------------------
With Workbooks(NomNouvo).Worksheets("Feuil4") 'A ADAPTER!!!
    .Range("A2").Resize(UBound(Tb_Out, 1), 53) = Tb_Out
End With

'--------------------- LE COLORIAGE DES CELLULES MODIFIEES ---------------------------
With Workbooks(NomNouvo).Worksheets("Feuil4")
    DLig = .Range("A" & Rows.Count).End(xlUp).Row
    With .Range("A1:BA" & DLig)
        Set Trouve = .Find("¤")
        If Not Trouve Is Nothing Then
            firstAddress = Trouve.Address
            Do While Not Trouve Is Nothing And Trouve.Address <> firstAddress
                'on efface le signe de repérage : ¤
                Trouve.Value = Left(Trouve.Value, Len(Trouve.Value) - 3)
                'on colorie en rouge
                Trouve.Interior.Color = 255
                'on cherche la suivante
                Set Trouve = .FindNext(Trouve)
            Loop
        End If
    End With
End With
End Sub


    Code réalisé sans fichiers de test..... A voir donc

    Cordialement,
    Franck
    0
    1. Ecrelinf Messages postés 36 Statut Membre
       
      Y'a-t-il une manip à faire pour récupérer la macro car je ne vois que la première ligne ?

      En tout cas merci pour ta disponibilité Franck !
      0
    2. pijaku Messages postés 13513 Date d'inscription   Statut Modérateur Dernière intervention   2 773
       
      Non il s'agit d'un bug qui revient de temps à autre..... 
      Option Explicit

      Sub Refs_modif()
      '
      ' Refs_modif Macro
      '
      Dim Tb_Ancien(), Tb_Nouvo(), Tb_Out()
      Dim mesRef_Ancien As Object
      Dim Trouve As Range

      Dim NomAncien As String, NomNouvo As String, firstAddress As String
      Dim ligneAncien As Long, ligneNouvo As Long, IndTbNouvo As Long
      Dim i As Long, j As Long, DLig As Long, Col As Byte

      Dim Modif As Boolean

      '--------------------- STOCKAGE DES DONNEES DANS LES VARIABLES ---------------------------
      'je récupère les noms de mes deux fichiers
      NomNouvo = ThisWorkbook.Name
      NomAncien = Workbooks(NomNouvo).Worksheets("Procedure").Range("B2").Value

          '**** STOCKAGE DE TOUTES LES DONNEES DE L'ANCIEN CLASSEUR
      With Workbooks(NomAncien).Worksheets("Items")
          'je compte le nombre de ligne dans mon ancien tableau
          ligneAncien = .Range("A" & Rows.Count).End(xlUp).Row
          'Stockage de toutes les données de Cells(1, 1) à Cells(ligneAncien, 53)
          Tb_Ancien = .Range(.Cells(1, 1), .Cells(ligneAncien, 53)).Value
          '********** STOCKAGE DE LA LISTE DES REFERENCES DE L'ANCIEN TABLEAU
          Set mesRef_Ancien = CreateObject("Scripting.Dictionary")
          For i = LBound(Tb_Ancien) To UBound(Tb_Ancien)
              mesRef_Ancien(Tb_Ancien(i, 1)) = i
          Next i
      End With

          '**** STOCKAGE DE TOUTES LES DONNEES DU NOUVEAU CLASSEUR
      With Workbooks(NomNouvo).Worksheets("Items")
      'je compte le nombre de ligne dans mon nouveau tableau
          ligneNouvo = .Range("A" & Rows.Count).End(xlUp).Row
          'Stockage de toutes les données de Cells(1, 1) à Cells(ligneNouvo, 53)
          Tb_Nouvo = .Range(.Cells(1, 1), .Cells(ligneNouvo, 53)).Value
      End With


      '--------------------- TEST DES DONNEES ET REMPLISSAGE TABLEAU DE SORTIE : ---------------------------
      'boucle sur les références du nouveau tableau
      For IndTbNouvo = 1 To UBound(Tb_Nouvo, 1) '!!!!!!!!!!!!!!!! Si la feuille contient une ligne d'entête, commencer à 2
          Modif = False
          'Si elle existe dans les références de l'ancien
          If mesRef_Ancien.exists(Tb_Nouvo(IndTbNouvo, 1)) Then
              'On vérifie s'il y a eu des modifs dans les 53 colonnes :
              For Col = 2 To 53
                  If Tb_Nouvo(IndTbNouvo, Col) <> Tb_Ancien(mesRef_Ancien(Tb_Nouvo(IndTbNouvo, 1)), Col) Then
                      'on note qu'il y a eu modification sur cette ligne
                      Modif = True
                      'on repère la cellule modifiée
                      Tb_Nouvo(IndTbNouvo, Col) = Tb_Nouvo(IndTbNouvo, Col) & " ¤ "
                  End If
              Next Col
              'On stocke la ligne si elle a été modifiée :
              If Modif Then
                  j = j + 1
                  ReDim Preserve Tb_Out(1 To j, 1 To 53)
                  For Col = 1 To 53
                      Tb_Out(j, Col) = Tb_Nouvo(IndTbNouvo, Col)
                  Next
              End If
          End If
      Next IndTbNouvo

      '--------------------- RESTITUTION DES DONNEES ---------------------------
      With Workbooks(NomNouvo).Worksheets("Feuil4") 'A ADAPTER!!!
          .Range("A2").Resize(UBound(Tb_Out, 1), 53) = Tb_Out
      End With

      '--------------------- LE COLORIAGE DES CELLULES MODIFIEES ---------------------------
      With Workbooks(NomNouvo).Worksheets("Feuil4")
          DLig = .Range("A" & Rows.Count).End(xlUp).Row
          With .Range("A1:BA" & DLig)
              Set Trouve = .Find(" ¤ ")
              If Not Trouve Is Nothing Then
                  firstAddress = Trouve.Address
                  Do While Not Trouve Is Nothing And Trouve.Address <> firstAddress
                      'on efface le signe de repérage : ¤
                      Trouve.Value = Left(Trouve.Value, Len(Trouve.Value) - 3)
                      'on colorie en rouge
                      Trouve.Interior.Color = 255
                      'on cherche la suivante
                      Set Trouve = .FindNext(Trouve)
                  Loop
              End If
          End With
      End With
      End Sub

      Est ce mieux???
      0
    3. Ecrelinf Messages postés 36 Statut Membre
       
      Oui c'est mieux, je test ça et revient vers toi ;)
      0
    4. Ecrelinf Messages postés 36 Statut Membre
       
      Franck,
      Je suis en train de recopier le code et je me demandais si le fait d'utiliser la même variable IndTbNouvo danhs la ligne 
      If Tb_Nouvo(IndTbNouvo, Col) <> Tb_Ancien(mesRef_Ancien(Tb_Nouvo(IndTbNouvo, 1)), Col) Then
      ne signifie pas que les références sont forcément placées à la même ligne ?
      En effet, d'un tableau à un autre les références peuvent "changer" de ligne (selon que des références ait été ajoutées ou supprimées parmis les ligne du dessus).

      Cordialement,
      Ecrelinf
      0
    5. Ecrelinf Messages postés 36 Statut Membre
       
      Franck,

      J'ai testé la macro et pour la ligne : 
      ReDim Preserve Tb_Out(1 To j, 1 To 53)
      le débogueur m'informe que "l'indice n'appartient pas à la sélection".

      Bonne soirée.
      Cordialement,
      Ecrelinf
      0

Discussions similaires

RETROUVER VENDEUR Sur le bon coin
PTM_026 -
Didi64_549 -

4 réponses
Le bon coin, comment retrouver un pseudonyme ?
HYPERSENSIBLE -
Robin -

8 réponses
garder constant des calculs
jack2125 -
PHILOU10120 -

4 réponses
CALCULS
smart19 -
Dracknard -

4 réponses