XL 2019 PRESQUE RESOLU : Remplacer RecherchV complexe pour correspondance INPN et cardobs par VBA

lusert

XLDnaute Junior
Bonjour à tous !

Je m'adresse aujourd'hui à vous car malgré de nombreuses recherche, je n'arrive pas à trouver de solution à mon problème.

Pour me faciliter la retranscription des espèces que j'observe, je mets en lien le fichier Taxref et le fichier ou j'ai saisie mes noms d'espèces animales.
Ce fichier taxref est ma base de donnéeil y a plus de 200 000 lignes. Il se compose d'une colonne A avec toutes les espèces de france et de 20 autres colonnes (de B à AA) composé des champs de correspondance à l'espèce (par exemple A : Pic vert et en trouve en B : la famille de l'oiseaux et en C : en iddentifiant... ainsi de suite).
Nom latinNom FrançaisIDFamilleectectect
Picus viridisPic Vert4562Picidésectectect
Parus majorectectectectectect

Mon deuxième fichier correspondant aux espèces que j'ai observé, il y a donc une seul colonne de rempli de nom d'espèces et je souhaite que les colonne de B à AA soient complété par la formule recherchV (que vous pouvez lire en cellule B3 =SI(ESTNA(RECHERCHEV($A3;BD!$A$2:$H$12;B$1;FAUX));;(RECHERCHEV($A3;BD!$A$2:$H$12;B$1;FAUX)))
1234
Nom latinnom latinNom francaisIdFamille
Picus viridis=SI(ESTNA(RECHERCHEV($A3;BD!$A$2:$H$12;B$1;FAUX));;(RECHERCHEV($A3;BD!$A$2:$H$12;B$1;FAUX)))Pic vert4562Picidés

Avec cette formule je peux aisément trouver les champs de correspondances aux espèces que j'ai observé afin d'être au norme avec la directive INPN.
Le problème c'est que ma base de donnée est lourde, très lourdes et que ce retrouver avec plus de 500 liaisons, ça rend les mises à jours de sliasions ou des enregistrement assez long ( 15 à 25 mn d'attente).

Je me suis donc inspiré de cette macro ci-dessous, extraite d'un fichier excel modèle d'un forum mais j'ai oublié lequel)

Sub Bouton1_Cliquer()
For i = 2 To 1000
Range("M" & i) = WorksheetFunction.VLookup(Range("e" & i), Range("$a$2:$c$1000"), 3)
Next i
End Sub

Elle fonctionne mais que sur une seul et même feuille et on ne peut pas faire apparaître plus d'une colonne de correspondance.
Je suis pas assez doué pour comprendre comment transposé ma formule =SI(ESTNA(RECHERCHEV($A3;BD!$A$2:$H$12;B$1;FAUX));;(RECHERCHEV($A3;BD!$A$2:$H$12;B$1;FAUX))) en macro avec un bouton à cliquer.


Si vous avez des pistes je vous en remercierez 1000 fois car je sèche complément sur ce sujet.


Cordialement,


ps : je peux joindre mon fichier excel pour aider à visualiser mon problème

Lusert
 
Solution
Re, ça marche mais un peu bidouillée, mais en tout cas surement plus rapide.
Un savant mix up de nos deux solutions permettant de simplifier la vie à Lusert sur la base utilisée:
Code:
Sub RapatrieParametres()
Dim Derlig As Long, IndexL As Long, L As Long, C As Long, Base As String
' Declarer base à utiliser
Base = "BD_Insectes"
'-------------------------
Application.ScreenUpdating = False
Derlig = Application.WorksheetFunction.CountA(Range("A:A"))
With Sheets(Base)
    For L = 2 To Derlig
        IndexL = 0
        On Error Resume Next
        IndexL = Application.Match(Cells(L, 1), .Range("A:A"), 0)
        If Not IsError(IndexL) And IndexL <> 0 Then
            For C = 1 To 40
                Cells(L, C + 1) = .Cells(IndexL, C)...

Staple1600

XLDnaute Barbatruc
Re

•>lusert
Comme je le disais (message#3), on peut se contenter d'une version allégée de ton fichier
(et alors tu pourras la joindre directement sur le forum)
Tu as regardé la proposition soumise par Roblochon?
PS: J'ai bien vu que tu avais fini par me voir ;)
 

lusert

XLDnaute Junior
Je n'ai pas bien compris la fonction que Roblochon a mis en place. vraiment désolé de mon ignorance ^^ je suis plus fais pour faire du terrain, identifier les animaux.

=SUBSTITUE(@CELLULE("nomfichier";$A$1);"Bombus.xlsx"; "BDC_STATUTS_13.csv")
Base de données :C:\Users\luser\AppData\Local\Temp\BDC_STATUTS_13.csv
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re,
En PJ un exemple à adapter à votre fichier.
A noter que je l'ai réduit à 40 lignes. C'est suffisant pour bosser, et valider le principe.
On lance la macro par appui sur le bouton orange.
VB:
Sub RapatrieParametres()
Dim Derlig As Long, IndexL As Long, L As Long, C As Long
Application.ScreenUpdating = False
Derlig = Application.WorksheetFunction.CountA(Range("A1:A1000000"))
For L = 2 To Derlig
    If Not IsError(Application.Match(Cells(L, 1), Sheets("BD_Insectes").Range("A1:A1000000"), 0)) Then
        IndexL = Application.Match(Cells(L, 1), Sheets("BD_Insectes").Range("A1:A1000000"), 0)
        For C = 1 To 40
            Cells(L, C + 1) = Sheets("BD_Insectes").Cells(IndexL, C)
        Next C
    End If
Next L
End Sub
 

Pièces jointes

  • fiche_saisie_macrolikerecherchV_V2.xlsm
    29.8 KB · Affichages: 11

lusert

XLDnaute Junior
C:\Users\luser\OneDrive\Documents\MODELS_OUTILS de travail\Modèle Excel\TAXREF\Groupes_Taxonomique_Métropole_csv\[fiche_saisie_macrolikerecherchV.xlsm]BD_Insectes
Re,
En PJ un exemple à adapter à votre fichier.
A noter que je l'ai réduit à 40 lignes. C'est suffisant pour bosser, et valider le principe.
On lance la macro par appui sur le bouton orange.
VB:
Sub RapatrieParametres()
Dim Derlig As Long, IndexL As Long, L As Long, C As Long
Application.ScreenUpdating = False
Derlig = Application.WorksheetFunction.CountA(Range("A1:A1000000"))
For L = 2 To Derlig
    If Not IsError(Application.Match(Cells(L, 1), Sheets("BD_Insectes").Range("A1:A1000000"), 0)) Then
        IndexL = Application.Match(Cells(L, 1), Sheets("BD_Insectes").Range("A1:A1000000"), 0)
        For C = 1 To 40
            Cells(L, C + 1) = Sheets("BD_Insectes").Cells(IndexL, C)
        Next C
    End If
Next L
End Sub

Génialissime!

Ça fonctionne comme dans mes rêves.


Je vais maintenant adapter la macro pour quelle prenne en compte les 15000 autres données de la feuille bd insecte
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re,
Ce sera automatique.
VB:
Sheets("BD_Insectes").Range("A:A")
La ligne Derlig prend toute la base de données jusqu'à la dernière ligne.
Il faut juste toucher à : Sheets("BD_Insectes") pour les autres bases.
D'ailleurs, il y a plus simple :
Code:
Sub RapatrieParametres()
' Changez le nom de la base utilisée
Base = "BD_Insectes"
'-------------------------------------------------------
Dim Derlig As Long, IndexL As Long, L As Long, C As Long
Application.ScreenUpdating = False
Derlig = Application.WorksheetFunction.CountA(Range("A:A"))
For L = 2 To Derlig
    If Not IsError(Application.Match(Cells(L, 1), Sheets(Base).Range("A:A"), 0)) Then
        IndexL = Application.Match(Cells(L, 1), Sheets(Base).Range("A:A"), 0)
        For C = 1 To 40
            Cells(L, C + 1) = Sheets(Base).Cells(IndexL, C)
        Next C
    End If
Next L
End Sub
Vous n'avez juste à changer le nom de la base utilisée : Base=xxxxxx
et ne toucher à rien d'autres. ;)
 

Staple1600

XLDnaute Barbatruc
Re

•>sylvanu
Une question en passant
Ca ne fonctionnera pas ainsi aussi?
(non testé, d'où ma question ;))
VB:
Sub RapatrieParametres()
Dim Derlig As Long, IndexL As Long, L As Long, C As Long
Application.ScreenUpdating = False
Derlig = Application.WorksheetFunction.CountA(Range("A1:A1000000"))
For L = 2 To Derlig
IndexL = Application.Match(Cells(L, 1), Sheets("BD_Insectes").Range("A1:A1000000"), 0)
    If Not IsError(IndexL) Then
        For C = 1 To 40
            Cells(L, C + 1) = Sheets("BD_Insectes").Cells(IndexL, C)
        Next C
    End If
Next L
End Sub
 

lusert

XLDnaute Junior
Super ! Encore merci !
J'ai pu ajouter déjà pour la première version de macro les 10000 données et je vais tenter d'appliquer votre nouveau code vba pour voir ce que cela va donner.

Au vue de vos derniers messagesn j'ai l'impression d'avoir loupé un épisode. Le fichier quevous m'avez transmis, semble fonctionner, en tout cas quand j'écris de nouveaux nom d'espèces et que je clique sur le bouton alors il apparait les champs de correspodance
 

lusert

XLDnaute Junior
Merci à tous les deux !

J'ai donc tester ces 3 différents codes VBA et ils fonctionnent super bien même avec plus de 150 000 ligne en BD.
Par contre je n'ai pas bien saisie où je devrais rajouter ce code : Sheets("BD_Insectes").Range("A:A")

afin que comme vous dites ça soit automatique ? IL faut ramplacer cette ligne ci-dessous si je comprends bien ?
Sheets("BD_Insectes").Range("A1:A1000000"),
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Si vous avez pris le code du post #21 vous n'avez rien à faire. C'était en réponse à votre post :
Je vais maintenant adapter la macro pour quelle prenne en compte les 15000 autres données de la feuille bd insecte
Je disais que vous n'avez rien à faire puisque celle ligne s'en charge. ( recherche de l'ensemble des lignes )
Sur le code du post #21 vous n'avez juste qu'à changer :
VB:
Base = "BD_Insectes"
par, par exemple :
Base = "BD_Oiseaux"
et rien d'autre.
Il vous faut donc une macro par base de données. ( il suffit de faire un copier coller et de changer le nom.
 

Staple1600

XLDnaute Barbatruc
Re

•>sylvanu
Je ne sais pas si c'est orthodoxe, mais cela fonctionne, non?
VB:
Sub RapatrieParametres()
Dim Derlig As Long, IndexL As Long, L As Long, C As Long
Application.ScreenUpdating = False
Derlig = Application.WorksheetFunction.CountA(Range("A1:A1000000"))
With Sheets("BD_Insectes")
    For L = 2 To Derlig
    On Error Resume Next
    IndexL = Application.Match(Cells(L, 1), .Range("A1:A1000000"), 0)
        If Not IsError(IndexL) Then
            For C = 1 To 40
                Cells(L, C + 1) = .Cells(IndexL, C)
            Next C
        End If
    Next L
End With
End Sub
(je viens de tester sur ton fichier exemple ;))
 

lusert

XLDnaute Junior
J'ai pu tester cette dernière macro. Elle fonctionne aussi bien que les autres.
Je crois qu'avec toutes ces informations, il est maintenant inutile de continuer à alimenter le fil de la discutions. Je m'en vais de ce pas trouver comme clôture la discutions.

Encore merci pour les différentes solutions proposées
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re, ça marche mais un peu bidouillée, mais en tout cas surement plus rapide.
Un savant mix up de nos deux solutions permettant de simplifier la vie à Lusert sur la base utilisée:
Code:
Sub RapatrieParametres()
Dim Derlig As Long, IndexL As Long, L As Long, C As Long, Base As String
' Declarer base à utiliser
Base = "BD_Insectes"
'-------------------------
Application.ScreenUpdating = False
Derlig = Application.WorksheetFunction.CountA(Range("A:A"))
With Sheets(Base)
    For L = 2 To Derlig
        IndexL = 0
        On Error Resume Next
        IndexL = Application.Match(Cells(L, 1), .Range("A:A"), 0)
        If Not IsError(IndexL) And IndexL <> 0 Then
            For C = 1 To 40
                Cells(L, C + 1) = .Cells(IndexL, C)
            Next C
        End If
    Next L
End With
End Sub
L'astuce à rajouter est IndexL=0, sinon s'il ne trouve pas le Resume Next laisse à IndexL la valeur précédente.

Lusert, prenez cette macro collégiale, elle est plus rapide.
 

Discussions similaires

Statistiques des forums

Discussions
315 098
Messages
2 116 189
Membres
112 679
dernier inscrit
Yupanki