Comparaison de 2 feuilles et ajout à conditions

Le 04/04/2017 à 22:59

Bonjour à tous,

Je viens vous demander de l'aide car j'ai un petit soucis dans l'exécution de ma macro.

Je cherche à comparer 2 feuilles comportant des données similaires. Si la cellule recherchée n'est pas trouvé dans la feuille "analyse programme", alors on l'ajoute à la suite. Si jamais elle est trouvée et que l'une des cellules adjacentes à celle trouvée ne correspond pas aux cellules adjacentes à la cellule testée, alors on l'ajoute à la suite. J'ai pu trouvé de l'info sur le find dans le cas ou ce n'est pas trouvé, ce qui semble me poser problèmes ici. J'ai l'impression de ne pas pouvoir effectuer une opération d'ajout dans le cas ou le find est négatif. Avez-vous une solution à me proposer ?

Merci de votre aide.

EDIT: Le programme semble ne pas aimer le Find(). Address.Row Je chercher à récupérer la ligne car le résultat ne peut étre que dans la premiere colonne.

Sub MAJAUTO()

Dim INBDN As Worksheet
Dim AP As Worksheet
Dim PlageBDN As Range
Dim PlageAP As Range
Dim derl As Integer
Dim Cell As Range
Dim test As Range
Dim resultat As Range

INBDN = Worksheets("Base de données")
AP = Worksheets("Analyse Programmes")

With INBDN: Set PlageBDN = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)): End With
With AP: Set PlageAP = .Range(.Cells(10, 1), .Cells(.Rows.Count, 7).End(xlUp)): End With

derl = Worksheets("Analyse Programmes").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1

For Each Cell In PlageBDN
'On regarde si la cellule considérée (Item Number) est déja présent dans l'analyse des programmes existants
 Set test = PlageAP.Find(Cell)

    If test Is Nothing Then 'Non
    'Si elle n'est pas présente alors on vient coller les 4 cellules dans la feuille "Analyse Programmes"
    ' à la suite des données déja présentes

        Worksheets("Analyse Programmes").Cells(derl, 1) = Cell
        Worksheets("Analyse Programmes").Cells(derl, 2) = Cell.Offset(, 2)
        Worksheets("Analyse Programmes").Cells(derl, 3) = Cell.Offset(, 3)
        Worksheets("Analyse Programmes").Cells(derl, 7) = Cell.Offset(, 1)

        derl = derl + 1

    End If

    If Not test Is Nothing Then 'Non+Non=Oui

        resultat = PlageAP.Cells.Find(Cell).Address.Row

        'Comment récupérer la position de la cellule ?
        'Ici la cellule recherchée est dans la page, il faut alors comparer les TAPE et les REV.
            If resultat.Offset(, 1) <> Cell.Offset(, 2) Or resultat.Offset(, 2) <> Cell.Offset(, 3) Then

            AP(derl, 1) = Cell
            AP(derl, 2) = Cell.Offset(, 2)
            AP(derl, 3) = Cell.Offset(, 3)
            AP(derl, 7) = Cell.Offset(, 1)

            derl = derl + 1
            End If

    End If
Next Cell

End Sub
Le 05/04/2017 à 02:09

Salut CharlesIrca,

sans fichier réel, comme on dit dans ce cas-là : à tester et, sans doute, à adapter!

'
Dim INBDN, AP As Worksheet
Dim tTab1, tTab2
Dim iRow As Integer
'
Set INBDN = Worksheets("Base de données")
Set AP = Worksheets("Analyse Programmes")
'
With INBDN
    tTab1 = .Range("A2:D" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
'
Application.ScreenUpdating = False
'
With AP
    For x = 1 To UBound(tTab1, 1)
        iRow = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
        tTab2 = .Range("A1:I" & iRow)
        iOK = 0
        For y = 1 To UBound(tTab2, 1)
            For Z = 1 To UBound(tTab2, 2) - 2
                If tTab1(x, 1) = tTab2(y, Z) Then
                    iOK = 1 'Oui
                    Exit For
                End If
                If Z = 7 Then Exit For
            Next
            iOK = IIf(iOK = 1 And tTab2(y, Z + 1) = tTab1(x, 3) And tTab2(y, Z + 2) = tTab1(x, 4), 1, 0)
            If iOK = 0 Then
                .Cells(iRow, 1) = tTab1(x, 1)
                .Cells(iRow, 2) = tTab1(x, 3)
                .Cells(iRow, 3) = tTab1(x, 4)
                .Cells(iRow, 7) = tTab1(x, 2)
            End If
        Next
    Next
End With
'
Application.ScreenUpdating = True
'

A+

8mef.xlsm (23.81 Ko)
Le 05/04/2017 à 15:49

Merci curulis57

Je suis un peu mêlé dans ton code et je ne pense pas bien comprendre les fonctions que tu utilises. Peux tu écrire quelques commentaires la dessus ?

De plus, j'ai fais un test avec le fichier que tu m'as donné, je te le retourne. Pour faire simple, la donnée de la colonne B ne doit pas être un critère, mais les données des colonnes A,C,D sont des critères. Si A,C et D sont dans la feuille "Analyse Programme" alors on colle la colonne B de "Base de données" dans la colonne G de "Analyse Programmes". Comme je n'arrive pas à comprendre ton code je ne vois pas ou je peux modifier cela ...

Autre question, comme on active ta macro ? Je ne connais pas l'utilisation de ton bouton rouge ... J'ai du créer mon Click Bouton ...

Merci pour ton aide, c'est super

5copie-de-mef.xlsm (22.37 Ko)
Le 05/04/2017 à 22:59

Salut CharlesIrca,

j'ai l'habitude de traiter de gros volumes (ou supposés tels) en 'capturant' ces données dans des tableaux (tTab1 et tTab2) pour accélérer le traitement en mémoire.

Pour être cohérent, je devrais même aller plus loin encore avec ton fichier mais bon...

Cela dit, plusieurs choses à mettre au point:

- EDIT: Le programme semble ne pas aimer le Find(). Address.Row Je chercher à récupérer la ligne car le résultat ne peut être que dans la première colonne

or tu définis la zone de recherche sur plusieurs colonnes...

  • Set PlageAP = .Range(.Cells(10, 1), .Cells(.Rows.Count, 7).End(xlUp))
  • Set test = PlageAP.Find(Cell)
Qu'en est-il, tout compte fait?

- Tes critères pour copie =

If resultat.Offset(, 1) <> Cell.Offset(, 2) Or resultat.Offset(, 2) <> Cell.Offset(, 3) Then … copie

=si Résultat+1 <> ColonneC OU si Résultat+2 <> Colonne4, on copie -> = donc si les deux pareils, pas de copie

= -> iOK = IIf(iOK = 1 And tTab2(y, Z + 1) = tTab1(x, 3) And tTab2(y, Z + 2) = tTab1(x, 4), 1, 0)

If iOK = 0 Then... copie

- or tu dis maintenant

Si A,C et D sont dans la feuille "Analyse Programme" alors on colle la colonne B

Ce n'est plus pareil!

On va déjà essayer d'accorder nos violons sur ça! D'ac?

A+

Le 06/04/2017 à 19:17

On peut clore le sujet, j'ai fais un processus un peu différent, voici comment:

J'ai crée une colonne ou je compare (en concaténant) mes données d'entrées vers ma base de données de fichiers traité. Si jamais, il ne les trouve pas ( c'est à dire il me retourne #N/A) dans ce cas, je mets la variable à 0:

=SI(ESTNA(RECHERCHEV([@[Item Number]]&[@[No Tape]]&[@REV];'Analyse Programmes'!H:H;1;FAUX))=FAUX;0;1)

ENsuite, j'utilise la macro suivante:

Sub TOTO()
Dim CPT As Integer
Dim CPT1 As Integer

CPT = 0
10
If Range("A2").Offset(CPT, 0) = "" Then

Else

    If Range("A2").Offset(CPT, 4) = 1 Then
        Item_Number = Range("A2").Offset(CPT, 0)
        Seq = Range("A2").Offset(CPT, 1)
        No_Tape = Range("A2").Offset(CPT, 2)
        REV = Range("A2").Offset(CPT, 3)

        CPT1 = 0
20

            If Sheets("Analyse Programmes").Range("A9").Offset(CPT1, 0) = "" Then
            Sheets("Analyse Programmes").Range("A9").Offset(CPT1, 0) = Item_Number
            Sheets("Analyse Programmes").Range("A9").Offset(CPT1, 1) = No_Tape
            Sheets("Analyse Programmes").Range("A9").Offset(CPT1, 2) = REV
            Sheets("Analyse Programmes").Range("A9").Offset(CPT1, 6) = Seq
            Sheets("Analyse Programmes").Range("A9").Offset(CPT1, 7).FormulaR1C1 = "=RC[-7]&RC[-6]&RC[-5]"
            Sheets("Analyse Programmes").Range("A9").Offset(CPT1, 4).FormulaR1C1 = "=COUNTIF(RC[4]:RC[20],""*"")"
            CPT = CPT + 1
            GoTo 10
            Else
            CPT1 = CPT1 + 1
            GoTo 20
            End If

       End If

CPT = CPT + 1
GoTo 10
End If

End Sub

Merci pour ton aide curulis57

Rechercher des sujets similaires à "comparaison feuilles ajout conditions"