Appairer Données

aubelix · 26 Août 2010

Bonjour à tous les amis du Forum. 🙂

Je reviens une nouvelle fois vers vous pour demander votre aide.
Mon problème est les suivant:

J'ai trouvé le code pour appairer des données, mais via

Code:

  Set rListOne = Application.InputBox _
                       (Prompt:="Sélectionnez la liste. Ne pas inclure les en-têtes", _
                        Title:="APPAIRER dates création.", Type:=8)
        If rListOne Is Nothing Then End
 
        Set rListTwo = Application.InputBox _
                       (Prompt:="Sélectionnez la liste. Ne pas inclure les en-têtes", _
                        Title:="APPAIRER avec fiches...", Type:=8)
        If rListTwo Is Nothing Then End

J'aurais aimé automatiser cette tâche pour éviter de selectionner
les données manuellement.

En sachant que la position des colonnes est toujours le même, mais
le nombre de ligne est variable.

Par avance, Merci pour votre aide.
Cordialement.

mromain · 26 Août 2010

Re : Appairer Données

Bonjour aubelix,

En supposant que D2: D33 est rListOne :

VB:

'on travaille avec la "Feuil1"
With ThisWorkbook.Sheets("Feuil1")
    '"rListOne" = "Feuil1!D2D<dernièreLigne>"
    Set rListOne = .Range("D2:D" & .Range("D" & .Rows.Count).End(xlUp).Row)
End With

Sinon, que doit faire ton code ? - Par pure curiosité 😉

a+

aubelix · 26 Août 2010

Re : Appairer Données

Bonjour mromain. 🙂

Merci pour ta réponse.

Pour ta question volià la réponse :
j'ai des Références (colonne D) avec une date colonne E qui détermine le début du travail.
Toutes les références et dates doivent être renseignées.
Un nouvel état est extrait, je dois renseigner les dates des nouvelles références.
Manuellemnt, je n'ai pas le choix.
Je compare si toutes les références ont été renseignées.
C'est pour cette raison que je les appaire. Un gros traitement est exécuté si toutes
les références sont renseignées, sinon, il plante....

Pour en revenir à ton code, il fonctionne, mais je dois le lancer 2 fois.
le 1er lancement, il trouve 33 erreurs et le 2ème, il trouve bien 6 erreurs Pourquoi ?

Code:

[COLOR=darkgreen]'on travaille avec la "Feuil1"[/COLOR]
With ThisWorkbook.Sheets("Feuil1")
    '"rListOne" = "Feuil1!D2D<dernièreLigne>"
    Set rListOne = .Range("D2:D" & .Range("D" & .Rows.Count).End(xlUp).Row)
End With
 
 
 
 
With ThisWorkbook.Sheets("Feuil1")
    '"rListOne" = "Feuil1!D2D<dernièreLigne>"
    Set rListTwo = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
 
 
 
        iColDiff = WorksheetFunction.Max(rListOne.Column, rListTwo.Column) _
                 - WorksheetFunction.Min(rListOne.Column, rListTwo.Column)
 
 
        rListTwo.Offset(0, 1).FormulaR1C1 = _
        "=VLOOKUP(RC[-1]," & rListOne.Address _
                                            (ReferenceStyle:=xlR1C1) & " ,2,FALSE)"
 
        rListTwo.Offset(0, 1) = rListTwo.Offset(0, 1).Value

Merci pour ton aide.
Cordialement.

aubelix · 26 Août 2010

Re : Appairer Données

Bonsoir. 🙂

Je me permets de vous relancer car il y'a un phénomène Bizarre...
Quelqu'un pourrai-t-il me l'expliquer et corriger le BUG.

Je suis obligé de lancer 2 fois la macro pour arriver au résultat.
1er Lancement affichage de 33 erreurs (Résultat Faux).
2ème Lancement affichage de 6 erreurs (Résultat Correct)

Par avance, Merci pour votre aide.
Cordialement.

mromain · 27 Août 2010

Re : Appairer Données

bonjour aubelix,

Ne comprenant pas tout à ton code, j'en ai refait un autre.

VB:

Sub comparaison()

    Range("D2").Select
    Dim rListOne As Range, rListTwo As Range, curCell As Range
    Dim nbErr As Integer
    
    'on travaille avec la "Feuil1"
    With ThisWorkbook.Sheets("Feuil1")
        '"rListOne" = "Feuil1!D2D<dernièreLigne>"
        Set rListOne = .Range("D2:D" & .Range("D" & .Rows.Count).End(xlUp).Row)
        
        Set rListTwo = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    End With
    
    'boucler sur chaque élément de rListTwo
    For Each curCell In rListTwo.Cells
'        If Not rListOne.Find(curCell, , xlValues, xlWhole) Is Nothing Then curCell.EntireRow.Hidden = True

        'si on ne trouve pas l'équivalent dans rListOne
        If rListOne.Find(curCell, , xlValues, xlWhole) Is Nothing Then
            'colorer la cellule
            curCell.Interior.Color = RGB(255, 0, 0)
            nbErr = nbErr + 1
        Else
            curCell.Interior.Color = xlNone
        End If

    Next curCell
    
    MsgBox nbErr & " erreurs."
End Sub

Il colorie les cellules non "appairées".

a+

aubelix · 28 Août 2010

Re : Appairer Données

Bonjour mromain 🙂

Merci pour ta réponse et ton aide.

Le principe des couleurs est très intéréssant.
Il permet en effet d'avoir une photo instantanée des erreurs.
Est-il possible en gardant ce principe d'écrire à droite de l'erreur
trouvée par exemple "ERREUR" en continuer à afficher le
nombre d'erreurs et de faire un filtre sur ces erreurs afin que je
puisse apporter les modifications qui s'impossent.

Par avance, Merci.
Cordialement

mromain · 30 Août 2010

Re : Appairer Données

Bonjour aubelix,

Voici un essai :

VB:

Sub Comparaison()

    Range("D2").Select
    Dim rListOne As Range, rListTwo As Range, curCell As Range
    Dim nbErr As Integer
    
    Application.ScreenUpdating = False
    
    'on travaille avec la "Feuil1"
    With ThisWorkbook.Sheets("Feuil1")
        '"rListOne" = "Feuil1!D2D<dernièreLigne>"
        Set rListOne = .Range("D2:D" & .Range("D" & .Rows.Count).End(xlUp).Row)
        
        Set rListTwo = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    
        'boucler sur chaque élément de rListTwo
        For Each curCell In rListTwo.Cells
    
            'si on ne trouve pas l'équivalent dans rListOne
            If rListOne.Find(curCell, , xlValues, xlWhole) Is Nothing Then
                'colorer la cellule
                curCell.Resize(1, 2).Interior.Color = RGB(255, 0, 0)
                curCell.Offset(0, 1).Value = "ERREUR"
                nbErr = nbErr + 1
            Else
                curCell.Resize(1, 2).Interior.Color = xlNone
            End If
    
        Next curCell
        
        'filtrer sur les erreurs
        .Range("B1").AutoFilter Field:=2, Criteria1:="ERREUR"
            
        
        
        Application.ScreenUpdating = True
        If nbErr = 0 Then
            Call MsgBox("    AUCUNE erreur détectée         ", vbInformation, "Pour info. . .")
            .ShowAllData
        Else
            'Compte les nombre de fiche inox sans date après filtrage
            Call MsgBox("    " & nbErr & "  ERREURS détectées            " & Chr(13) & "          Veuilez les corriger     ", vbCritical, " Attention !")
        End If
    End With
End Sub



Sub Montrer_Tout()
    On Error Resume Next
    With ThisWorkbook.Sheets("Feuil1")
        .ShowAllData
        .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown).Offset(0, 1)).Interior.Color = xlNone
        .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Offset(0, 1).Clear
    End With
End Sub

J'ai également modifié la macro Montrer_Tout().

a+

aubelix · 30 Août 2010

Re : Appairer Données

Bonsoir mromain. 🙂

Mille mercis pour ta réponse et ton aide.
La macro convient tout à fait à ce que je recherchais à faire.

Cordialement.

Appairer Données

aubelix

XLDnaute Impliqué

Pièces jointes

mromain

XLDnaute Barbatruc

aubelix

XLDnaute Impliqué

aubelix

XLDnaute Impliqué

Pièces jointes

mromain

XLDnaute Barbatruc

aubelix

XLDnaute Impliqué

mromain

XLDnaute Barbatruc

aubelix

XLDnaute Impliqué

Discussions similaires

Appairer Données

XLDnaute Impliqué

Pièces jointes

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Impliqué

Pièces jointes

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Impliqué

Discussions similaires

Privacy & Transparency

Privacy & Transparency