XL 2016 RechercheV dans un autre classeur

[KTM]

Bonjour Chers tous
Je voudrais une macro qui me permettra depuis mon classeur2 de récupérer les données des feuilles de mon classeur1 a partir des codes.
Merci et excellente Journée.

 

[dysorthographie]

Bonjour,

[XL-2013] Fonctionne recherche vba - Macros et VBA Excel

Voila mon problème: Je cherche un code pour faire de la recherche de ce type : j'ai un formulaire de recherche avec 2 texbox et un bouton recherche, donc 2 critère de recherche différent. Quand je lance la

www.developpez.net

SerchXls(Workbooks("Classeur2").Sheets("Feuil2").Range("A:A"), etc.

 

[job75]

Bonjour KTM, dysor, le forum,

C'est simple en supposant que :

- il y a les mêmes feuilles à traiter dans les 2 fichiers

- il s'agit toujours d'étudier les colonnes 1, 3 et 5 des plages A5:E15 et A5:E17.

La macro dans le ThisWorkbook de Classeur2.xlsm :

Private Sub Workbook_Activate()
Dim feuille, adr1$, adr2$, wb As Workbook, f, P1 As Range, P2 As Range, col%, lig&, v As Variant
feuille = Array("Feuil1", "Feuil2", "Feuil3", "Feuil4", "Feuil5") 'liste à adapter au besoin
adr1 = "A5:E15" 'adresse pour Classeur1
adr2 = "A5:E17" 'adresse pour Classeur2
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Set wb = Workbooks.Open(Me.Path & "\Classeur1.xlsm") 'ouverture du fichier source, à adapter au besoin
For Each f In feuille
    Set P1 = wb.Sheets(f).Range(adr1)
    Set P2 = Me.Sheets(f).Range(adr2)
    For col = 3 To 5 Step 2 'colonnes à traiter
        P2.Columns(col) = Empty 'RAZ
        For lig = 1 To P2.Rows.Count
            v = Application.VLookup(P2(lig, 1), P1, col, 0)
            If Not IsError(v) Then P2(lig, col) = v
Next lig, col, f
wb.Close False
Application.EnableEvents = True 'réactive les évènements
End Sub

Les 2 fichiers doivent être placés dans le même dossier (le bureau).

A+

 

[KTM]

Bonjour KTM, dysor, le forum,

C'est simple en supposant que :

- il y a les mêmes feuilles à traiter dans les 2 fichiers

- il s'agit toujours d'étudier les colonnes 1, 3 et 5 des plages A5:E15 et A5:E17.

La macro dans le ThisWorkbook de Classeur2.xlsm :

Private Sub Workbook_Activate()
Dim feuille, adr1$, adr2$, wb As Workbook, f, P1 As Range, P2 As Range, col%, lig&, v As Variant
feuille = Array("Feuil1", "Feuil2", "Feuil3", "Feuil4", "Feuil5") 'liste à adapter au besoin
adr1 = "A5:E15" 'adresse pour Classeur1
adr2 = "A5:E17" 'adresse pour Classeur2
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Set wb = Workbooks.Open(Me.Path & "\Classeur1.xlsm") 'ouverture du fichier source, à adapter au besoin
For Each f In feuille
    Set P1 = wb.Sheets(f).Range(adr1)
    Set P2 = Me.Sheets(f).Range(adr2)
    For col = 3 To 5 Step 2 'colonnes à traiter
        P2.Columns(col) = Empty 'RAZ
        For lig = 1 To P2.Rows.Count
            v = Application.VLookup(P2(lig, 1), P1, col, 0)
            If Not IsError(v) Then P2(lig, col) = v
Next lig, col, f
wb.Close False
Application.EnableEvents = True 'réactive les évènements
End Sub

Les 2 fichiers doivent être placés dans le même dossier (le bureau).

A+

MERCI JOB75

 

[job75]

Avec la macro précédente si les plages à traiter sont grandes l'exécution prendra du temps.

Pour accélérer utiliser cette macro qui utilise des tableaux VBA et le Dictionary :

Private Sub Workbook_Activate()
Dim feuille, adr1$, adr2$, d As Object, wb As Workbook, f, tablo1, P As Range, tablo2, col%, lig&
feuille = Array("Feuil1", "Feuil2", "Feuil3", "Feuil4", "Feuil5") 'liste à adapter au besoin
adr1 = "A5:E15" 'adresse pour Classeur1
adr2 = "A5:E17" 'adresse pour Classeur2
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Set wb = Workbooks.Open(Me.Path & "\Classeur1.xlsm") 'ouverture du fichier source, à adapter au besoin
For Each f In feuille
    tablo1 = wb.Sheets(f).Range(adr1) 'matrice, plus rapide
    Set P = Me.Sheets(f).Range(adr2)
    tablo2 = P.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
    For col = 3 To 5 Step 2 'colonnes à traiter
        d.RemoveAll 'RAZ
        ReDim resu(1 To UBound(tablo2), 1 To 1)
        For lig = 1 To UBound(tablo1)
            d(tablo1(lig, 1)) = tablo1(lig, col) 'mémorise la valeur
        Next lig
        For lig = 1 To UBound(tablo2)
            resu(lig, 1) = d(tablo2(lig, 1))
        Next lig
        P.Columns(col) = resu 'restitution
Next col, f
wb.Close False
Application.EnableEvents = True 'réactive les évènements
End Sub

 

[job75]

Pour tester j'ai recopié les tableaux sur 11 000 lignes (Classeur1.xlsm) et 13 000 lignes (Classeur2.xlsm).

Sans doublons en colonnes A.

Durées d'exécution :

- macro du post #3 => 160 secondes

- macro du post #5 => 1,4 seconde chez moi sur Win 11 Excel 2019.