Discussion :

[Lison Lisette]

Bonjour…

J’éprouve quelques difficultés à me faire comprendre par VBA…

Je m’explique.

J’ai deux fichiers :
- un fichier « BDD » = une base de données
- un fichier de travail à remplir

J’aimerais que la macro «scanne» la deuxième colonne du fichier de travail «à compléter », et qu'elle recherche dans BDD ce qu'elle y trouve
- Si elle trouve un identifiant correspondant dans la BDD (rechercher dans la colonne 1), insérer en vert toutes les lignes de la BDD correspondante juste au-dessus de cet identifiant dans le fichier de travail
- Si elle ne trouve pas l’identifiant dans la BDD, mettre en rouge

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Démo_test_comparaison_BDD()
 
Application.ScreenUpdating = False
 
'Macro recherche de correspondances dans la BDD
 
Dim Kol As New Collection
Dim LastLig1 As Long, LastLig2 As Long, i As Long
Dim c As Range
 
'mémoriser tous les ID de la feuille de travail à compléter
With Sheets("A compléter")
    .AutoFilterMode = False
    LastLig2 = .Cells(Rows.Count, 2).End(xlUp).Row
 
    For i = 2 To LastLig2
        On Error Resume Next
        Kol.Add .Range("A" & i).Value, .Range("A" & i).Value
        On Error GoTo 0
    Next i
 
'recherche de l'élément dans la feuille BDD
    For i = 1 To Kol.Count
        With Sheets("BDD")
            .AutoFilterMode = False
            LastLig1 = .Cells(Rows.Count, 1).End(xlUp).Row
        End With
        .Range("A1").AutoFilter field:=1, Criteria1:=Kol(i)
        Set c = Sheets("BDD").Range("A1:A" & LastLig1).Find(Kol(i), lookat:=xlWhole)
 
'dans le cas ou l'id existe dans la BDD, le colorier en vert et le copier dans la feuille de calcul
 
'...comment faire insérer toutes ces lignes non pas à la fin du code mais juste en dessus de l'identifiant en question ?
        If Not c Is Nothing Then
            Sheets("BDD").Range("A1").AutoFilter field:=1, Criteria1:=Kol(i)
 
            .Range("A2:L" & LastLig2).SpecialCells(xlCellTypeVisible).Interior.ColorIndex = 4
            .Range("A2:L" & LastLig2).SpecialCells(xlCellTypeVisible).Copy Sheets("A compléter").Range("B" & LastLig1 + 1)
            Set c = Nothing
 
'dans le cas ou il n'existe pas, mettre la la cellule de l'id en rouge dans le formulaire
        Else
            .Range("A2").SpecialCells(xlCellTypeVisible).Interior.ColorIndex = 3
        End If
    Next i
    .AutoFilterMode = False
End With
Sheets("BDD").AutoFilterMode = False
 
End Sub

Problème 1 : la question est dans le code

Problème 2 : cette macro s'applique à deux feuilles dans un même classeur, il suffit de rajouter

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

worksheets("gffdg")

devant chaque

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

sheet("qqch")

pour que ça marche entre deux classeurs différents ? Mais comment faire dans le cas ou les classeurs ont des noms différents à chaque fois ? Je pense que la macro sera liée au fichier "BDD" donc pour ce classeur il faudrait mettre ActiveWorksheet.Sheet("qqch") ? Il existe une possibilité en VBA de faire ouvrir à l'utilisateur une msgbox ou il irait chercher le deuxième fichier (genre le fameux parcourir...) et enregistrer le nom du fichier à ce moment là ?

Problème 3 : Pourquoi cette macro ne fonctionne pas en l'état actuel, mais ne m'envoie aucun msg d'erreur (et me laisse donc un peu dans le flou sur comment résoudre le problème !)

[mercatog]

A mettre dans fichier BDD, long à expliquer avec possibilité d'expliquer
A adapter au cas où les fichiers réels sont différents de l'exemple
A comprendre aussi

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Export()
Dim wbk As Workbook
Dim Sh As Worksheet, aSh As Worksheet
Dim Fichier As Variant
Dim Kol As New Collection
Dim LastLig1 As Long, LastLig2 As Long, i As Long, Nb As Long, vRow As Long
Dim c As Range
 
Application.ScreenUpdating = False
Set aSh = ThisWorkbook.Sheets("BDD")
 
Fichier = Application.GetOpenFilename("Excel Files (*.xls), *.xls")
If Fichier <> False Then
    Set wbk = Workbooks.Open(Fichier)
    Set Sh = wbk.Sheets(1)              'Ou Set Sh = wbk.Sheets("NomFeuilleACompléter")
    With aSh
        .AutoFilterMode = False
        LastLig1 = .Cells(Rows.Count, 1).End(xlUp).Row
    End With
    With Sh
        .AutoFilterMode = False
        LastLig2 = .Cells(Rows.Count, 2).End(xlUp).Row
        For i = 2 To LastLig2
            On Error Resume Next
            Kol.Add .Range("B" & i).Value, .Range("B" & i).Value  'les id en colonne B
            On Error GoTo 0
        Next i
        For i = 1 To Kol.Count
            vRow = .Range("B1:B" & LastLig2).Find(Kol(i), LookIn:=xlValues, Lookat:=xlWhole).Row
            Set c = aSh.Range("A1:A" & LastLig1).Find(Kol(i), LookIn:=xlValues, Lookat:=xlWhole)
            If Not c Is Nothing Then
                aSh.Range("A1:A" & LastLig1).AutoFilter Field:=1, Criteria1:=Kol(i)
                Nb = aSh.Range("A1:A" & LastLig1).SpecialCells(xlCellTypeVisible).Count - 1
                .Rows(vRow & ":" & vRow + Nb - 1).Insert
                LastLig2 = LastLig2 + Nb
                aSh.Range("A2:L" & LastLig1).SpecialCells(xlCellTypeVisible).Copy .Range("B" & vRow)
                .Range("B" & vRow & ":M" & vRow + Nb - 1).Font.ColorIndex = 14
                Set c = Nothing
                aSh.AutoFilterMode = False
            Else
                .Range("B" & vRow & ":M" & vRow).Font.ColorIndex = 3
            End If
        Next i
    End With
    wbk.Save
    wbk.Close
    Set Sh = Nothing
    Set wbk = Nothing
End If
Set aSh = Nothing
End Sub

[Lison Lisette]

Merci pour tout,

ça marche nickel (mis à part que certains de mes id restent en noir dans mes fichiers de travail... mais j'ai trouvé, c'est parce que les id ne sont pas uniques!)

Quelques explications si jamais ça peut servir à qqun.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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 Implémenter_data_BDD_dans_fichier_de_travail()
Dim wbk As Workbook
Dim Sh As Worksheet, aSh As Worksheet
Dim Fichier As Variant
Dim Kol As New Collection
Dim LastLig1 As Long, LastLig2 As Long, i As Long, Nb As Long, vRow As Long
Dim c As Range
 
Application.ScreenUpdating = False
 
Set aSh = ThisWorkbook.Sheets("BDD")
 
Fichier = Application.GetOpenFilename("Excel Files (*.xls), *.xls")
If Fichier <> False Then
    Set wbk = Workbooks.Open(Fichier)
    Set Sh = wbk.Sheets("MDL")              'Ou Set Sh = wbk.Sheets("NomFeuilleACompléter") sinon mettre wbk.Sheets(2) par exemple
    With aSh
        .AutoFilterMode = False                             'enlève filtre auto de la BDD
        LastLig1 = .Cells(Rows.Count, 1).End(xlUp).Row      'dernière ligne de la BDD
    End With
    With Sh
        .AutoFilterMode = False                             'enlever filtre auto de la feuille de travail
        LastLig2 = .Cells(Rows.Count, 2).End(xlUp).Row      'dernière ligne de la feuille de travail
        For i = 2 To LastLig2S                              'S ??????  pourquoi S ? faire tourner un i de la deuxième à la dernière ligne de la feuille de travail
            On Error Resume Next
            Kol.Add .Range("B" & i).Value, .Range("B" & i).Value  'on crée une collection des id en colonne B
            On Error GoTo 0    'si erreur rien faire
        Next i
        For i = 1 To Kol.Count 'on commence au 1er id de la collection
            vRow = .Range("B1:B" & LastLig2).Find(Kol(i), LookIn:=xlValues, Lookat:=xlWhole).Row '???? retenir le numéro de ligne ou on est
            Set c = aSh.Range("A1:A" & LastLig1).Find(Kol(i), LookIn:=xlValues, Lookat:=xlWhole) 'on cherche si ça existe dans BDD
            If Not c Is Nothing Then 'si il trouve dans BDD
                aSh.Range("A1:A" & LastLig1).AutoFilter Field:=1, Criteria1:=Kol(i) 'on filtre BDD sur ce critère
                Nb = aSh.Range("A1:A" & LastLig1).SpecialCells(xlCellTypeVisible).Count - 1 'on compte le nombre de lignes concernées (moins la ligne titre)
                .Rows(vRow & ":" & vRow + Nb - 1).Insert 'on isere toutes ces lignes une case au dessus de là ou on est
                LastLig2 = LastLig2 + Nb 'la dernière ligne remplie de la feuille de travail se décale vers le bas du nombre de lignes insérées
                aSh.Range("A2:L" & LastLig1).SpecialCells(xlCellTypeVisible).Copy .Range("B" & vRow) 'on copie dedans le contenu de la BDD filtrée sur le critère
                .Range("B" & vRow & ":M" & vRow + Nb - 1).Font.ColorIndex = 14 'on colorie les lignes insérées en vert
                Set c = Nothing
                aSh.AutoFilterMode = False 'on enlève le filtre de BDD
            Else
                '.Range("B" & vRow & ":M" & vRow).Font.ColorIndex = 3
                .Range("B" & vRow).Font.ColorIndex = 3 'on colorie l'id en rouge
            End If
        Next i
    End With
    wbk.Save 'sauver feuille de travail
    'wbk.Close
    Set Sh = Nothing
    Set wbk = Nothing
End If
Set aSh = Nothing
End Sub

[mercatog]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

        For i = 2 To LastLig2 'LastLig2S                              'S ??????  pourquoi S ? faire tourner un i de la deuxième à la dernière ligne de la feuille de travail

La variable est bien LastLig2 et non LastLigS!
Merci pour les commentaires sur le code.
les id qui restent en noir sont ceux initialement présent dans la feuille à compléter, c'est facile de les colorier (ligne vRow avant insertion des lignes ou vRow + Nb après insertion des lignes)