Comparaison donnée Excel

Version imprimable

17/02/2020, 16h13
dave5

2 pièce(s) jointe(s)

Comparaison donnée Excel

Bonjour la communauté,

Je sollicite votre aide afin de remplir un tableau en fonction d'un autre fichier en effet j'ai un premier fichier Liste_Source_fruit_test.xlsx qui correspond aux données sources avec des niveau 2, 3 et 4 qui correspondent respectivement au pays, mois et container avec une troisième colonne ou il y a des produit("fruits") et un deuxième fichier nommé Dash_Fruit.xlsm avec une colonne A pays et une ligne mois avec les fruits en dessous. je souhaite remplir mon deuxième fichier de façon a ce que quand les pays, les mois et fruits correspondent sur les deux fichiers-> mettre une case OK dans la bonne cellule avec un bouton : ouverture du fichier Liste_Source_fruit_test.xlsx(réalisé) , lecture et comparaison.
Merci pour votre aide.

Cordialement;

Bonjour,

J'ai modifié la structure du classeur "Liste_source_des_fruits" de manière à le rendre plus lisible et plus fonctionnel
Pièce jointe 539731

D'ailleurs pourquoi créer un deuxième classeur comme base de données, cette BDD dans une autre feuille du classeur "Dash_Fruit" eut été plus simple et aurait évité l'ouverture de ce deuxième classeur.

le fichier "Dash_Fruit"
Pièce jointe 539733

Dans le module de la feuille

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub CommandButton1_Click()
    Dim Fichier, NomFichier$
    Application.ScreenUpdating = False
    Fichier = Application.GetOpenFilename("Fichiers Microsoft Office Excel, *.xlsx")
    If Fichier = False Then Exit Sub
    If Fichier Like "*\" & ThisWorkbook.Name Then MsgBox "Ouverture non autorisée.": Exit Sub
    On Error Resume Next
    Workbooks.Open Fichier
    On Error GoTo 0
    NomFichier = Dir(Fichier)
    Workbooks(NomFichier).Activate
    Remplissage
End Sub

Dans un module standard

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
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
 
Sub Remplissage()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim i As Long, j As Long, l As Long, k As Long, c As Long
    Dim p As Object, m As Object
    Application.ScreenUpdating = False
    Windows("Liste_Source_fruit.xlsx").Activate
    Set f1 = Sheets("Liste_source_des_fruits")
    Set f2 = Sheets("Liste_des_pays")
    DerLig_Pays = f2.Range("A" & Rows.Count).End(xlUp).Row
    DerLig_Site = f1.Range("A" & Rows.Count).End(xlUp).Row
    ReDim Mois(DerLig_Site) As String
    ReDim Fruit(DerLig_Site) As String
    For i = 2 To DerLig_Pays
        Pays = f2.Cells(i, "A")
        NbFruits = 0
        For j = 2 To DerLig_Site
            l = j
            Do While f1.Cells(l, "A") = Pays
                If f1.Cells(l, "D") <> "" Then
                    Mois(l - 1) = f1.Cells(l, "B")
                    Fruit(l - 1) = f1.Cells(l, "D")
                End If
                l = l + 1
            Loop
        Next j
 
        'recopie dans fichier "Dash_fruit"
        l = l - 1
        Windows("Dash_Fruit.xlsm").Activate
        Set p = Columns(1).Find(Pays)
        For k = 1 To l
            If Mois(k) <> "" Then
                Set m = Rows(1).Find(Mois(k))
                c = m.Column
                If Not m Is Nothing Then
                   Do While Cells(2, c) <> Fruit(k)
                        c = c + 1
                    Loop
                    Cells(p.Row, c) = "Ok"
                    Mois(k) = ""
                    Fruit(k) = ""
                End If
            End If
        Next k
        Windows("Liste_Source_fruit.xlsx").Activate
    Next i
    Windows("Dash_Fruit.xlsm").Activate
    Set m = Nothing
    Set p = Nothing
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Cdlt

Bonjour,

Merci pour ta réponse c'est excatement ce que je voulais avoir comme résultat, je me permets de pousser un peu le sujet en effet au lieu d'avoir un simple Ok j'aimerai avoir un Ok avec l'occurrence du fruit qui s'y trouve au bon mois et en provenance du bon pays. j'ai essayé avec ce code mais ca ne fonctionne pas vu que je suis un grand nul en vba :calim2: ca ne m'étonne pas. Merci par avance de ton aide précieuse

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
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
Sub Remplissage()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim i As Long, j As Long, l As Long, k As Long, C As Long
    Dim p As Object, m As Object, y As Object
    Application.ScreenUpdating = False
    Windows("Liste_Source_fruit.xlsx").Activate
    Set f1 = Sheets("Liste_source_des_fruits")
    Set f2 = Sheets("Liste_des_pays")
    DerLig_Pays = f2.Range("A" & Rows.Count).End(xlUp).Row
    DerLig_Site = f1.Range("A" & Rows.Count).End(xlUp).Row
    ReDim Mois(DerLig_Site) As String
    ReDim Fruit(DerLig_Site) As String
 
 
    For i = 2 To DerLig_Pays
        Pays = f2.Cells(i, "A")
        NbFruits = 0
        For j = 2 To DerLig_Site
            l = j
            Do While f1.Cells(l, "A") = Pays
                If f1.Cells(l, "D") <> "" Then
                    Mois(l - 1) = f1.Cells(l, "B")
                    Fruit(l - 1) = f1.Cells(l, "D")
                End If
                l = l + 1
            Loop
        Next j
 
'            Dim NbOccurrence As Long
'    Dim V As Object
'    Dim NbOcur As Long
'    Dim FirstAdresse As String
'
'    'NbOcur = 0
'    With Plage
'        Set V = f1.Range("D2:D102").Find(Fruit, LookIn:=xlValues)
'        If Not V Is Nothing Then
'            FirstAdresse = V.Address()
'            Do
'                NbOcur = NbOcur + 1
'                'Set V = f1.Range("D2:D102").FindNext(V)
'            Loop While Not V Is Nothing And V.Address <> FirstAdresse
'        End If
'    End With
'
'    NbOccurrence = NbOcur
Dim Nb_OK As Long
 
 
 
 
        'recopie dans fichier "Dash_fruit"
        l = l - 1
        Windows("Dash_Fruit.xlsm").Activate
        Set p = Columns(1).Find(Pays)
        For k = 1 To l
            If Mois(k) <> "" Then
                Set m = Rows(1).Find(Mois(k))
                C = m.Column
                    Set y = Columns(4).Find(Fruit)
                    Nb_OK = y.Column
                    MsgBox Nb_OK
                If Not m Is Nothing Then
                   Do While Cells(2, C) <> Fruit(k)
                        C = C + 1
                        Nb_OK = Nb_OK + 1
                    Loop
                    Cells(p.Row, C) = "Ok" & "(" & Nb_OK & ")"
                    Mois(k) = ""
                    Fruit(k) = ""
                End If
            End If
        Next k
        Windows("Liste_Source_fruit.xlsx").Activate
    Next i
    Windows("Dash_Fruit.xlsm").Activate
    Set m = Nothing
    Set p = Nothing
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Bonjour,

Le fichier "Dash_Fruit"
Pièce jointe 540166

le code

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
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
Sub Remplissage()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim i As Long, j As Long, l As Long, k As Long, c As Long, Col As Long
    Dim p As Object, m As Object
    Application.ScreenUpdating = False
    Windows("Liste_Source_fruit.xlsx").Activate
    Set f1 = Sheets("Liste_source_des_fruits")
    Set f2 = Sheets("Liste_des_pays")
    DerLig_Pays = f2.Range("A" & Rows.Count).End(xlUp).Row
    DerLig_Site = f1.Range("A" & Rows.Count).End(xlUp).Row
    ReDim Mois(DerLig_Site) As String
    ReDim Fruit(DerLig_Site) As String
    For i = 2 To DerLig_Pays
        Pays = f2.Cells(i, "A")
        For j = 2 To DerLig_Site
            l = j
            Do While f1.Cells(l, "A") = Pays
                If f1.Cells(l, "D") <> "" Then
                    Mois(l - 1) = f1.Cells(l, "B")
                    Fruit(l - 1) = f1.Cells(l, "D")
                End If
                l = l + 1
            Loop
        Next j
 
        'recopie dans fichier "Dash_fruit"
        l = l - 1
        Windows("Dash_Fruit.xlsm").Activate
        DerCol_f1 = Range("D2").End(xlToRight).Column 'Dernière colonne du tableau
        Set p = Columns(1).Find(Pays)
        Range(Cells(p.Row, "D"), Cells(p.Row, DerCol_f1)).ClearContents 'effacement des précédents relevés
        For k = 1 To l
            If Mois(k) <> "" Then
                Set m = Rows(1).Find(Mois(k))
                c = m.Column
                If Not m Is Nothing Then
                   Do While Cells(2, c) <> Fruit(k)
                        c = c + 1
                    Loop
                    Cells(p.Row, c) = Cells(p.Row, c) + 1
                    Mois(k) = ""
                    Fruit(k) = ""
                End If
            End If
        Next k
        For Col = 4 To DerCol_f1
            If Cells(p.Row, Col) <> "" Then Cells(p.Row, Col).Value = "Ok" & Chr(10) & Cells(p.Row, Col).Value
        Next Col
        Windows("Liste_Source_fruit.xlsx").Activate
    Next i
 
    Windows("Dash_Fruit.xlsm").Activate
    Set m = Nothing
    Set p = Nothing
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Cdlt

21/02/2020, 15h11
dave5

Bonjour,

Merci, c'est le résultat attendu :) Bon Week End.