VBA_ copier coller une ligne entre 2 classeurs en fonction valeurs cellule

Bonjour à tous ,

Je reviens vers vous , j'ai une super macro grâce à @FINDRH , qui me permet de copier coller des lignes d'un onglet à un autre en fonction de filtres . J'essaye en vain de l'adapter pour que la macro fasse la même chose mais entre deux classeurs différents au lieu de 2 feuilles.

J'ai essayé de définir des variables pour donner les noms des classeurs mais je n'arrive pas à les intégrer .... Quelqu'un aurait une idée de comment faire ? merci :)

Ci dessous le code initial que j'essaye de modifier :

SUB test ()

'' recherche de la valeur en Workbook("AD").Sheets("TDB_Hebdo").Range("B6"),  dans Workbook("BC").Sheets("Liste_CC") et copie colle dans Workbook("AD").Sheets("CC")

Application.ScreenUpdating = False

Sheets("CC").Select

vfl = Range("A100000").End(xlUp).Row

If vfl > 11 Then
    Rows(12 & ":" & vfl).Select
    Selection.Delete
Range("A1").Select

Else
End If

vald = Sheets("TDB_Hebdo").Range("B6").Value

Sheets("Liste_CC").Select

If Worksheets("Liste_CC").AutoFilterMode Then
     Worksheets("Liste_CC").AutoFilterMode = False
 End If

[A1].AutoFilter

vfl = Range("A100000").End(xlUp).Row

    Range("A1").CurrentRegion.Select

    ActiveSheet.Range("$A$1:$I$" & vfl).AutoFilter Field:=4, Criteria1:="=" & vald, Operator:=xlAnd

    n = [Subtotal(3, A:A)] - 1 'nb lignes filtrées

    If n > 0 Then

        Range([A1], [A1].End(xlDown)).EntireRow.Select
        Selection.Copy Destination:=Sheets("CC").Rows("1:1")

           Else
        MsgBox " Pas de donnees "

    End If
     Application.ScreenUpdating = True

Sheets("TDB_Hebdo").Select

End Sub

Merci de m'avoir lue et bonne soirée à tous !

A

Bonjour

Ci joint un essai pas évident car je ne peux tester correctement ta version

J'ai rajouté un onglet Tables où tu rajoutes en B2 le nom du classeur source

Vérifie bien le nom des classeurs et des adresses de destination dans la procédure, j'ai arrêté ma vérif après le test d'ouverture du deuxième classeur. Pour lancer ( relancer surtout) la macro il faut être sur le classeur a remplir.

Dans l'attente de ton retour

Cordialement

FINDRH

Bonjour à tous , et Bonjour FINDRH,

Merci de m'avoir répondu et de ton aide , le code fonction j'y ai apporté quelques modifications , notamment le fait d'ouvrir le fichier via un chemin et non un autre onglet car le fichier source peut potentiellement changer de dossier .

Je vous met le code ci dessous avec mes modifications !

Merci encore pour votre aide :D

Public Vclas1, Vclas2, Vclas3 As String
Public Vfl As Long
Public Vald As Variant
''''''''''''''''''''''''''''''''
'Sub ouvrir()
   ' Application.FindFile
    'Vclas2 = ActiveWorkbook.Name
  'End Sub
'''''''''''''''''''''''''''''''''''''

Sub test()

'' recherche de la valeur en Workbook("AD").Sheets("TDB_Hebdo").Range("B6"),  dans Workbook("BC").Sheets("Liste_CC") et copie colle dans Workbook("AD").Sheets("CC")

Application.ScreenUpdating = False

' classeur résultat

Vclas1 = ActiveWorkbook.Name
Windows(Vclas1).Activate

'vider contenu résultat
Sheets("CC").Select

Vfl = Range("A100000").End(xlUp).Row

    If Vfl > 1 Then
        Rows(2 & ":" & Vfl).Select
        Selection.Delete
        Range("A1").Select

    Else

    End If

' valeur recherchée
    Vald = Sheets("TDB_Hebdo").Range("B6").Value

 ' recup nom du,classeur à ouvrir
    Vclas2 = "C:\Users\a.d\Desktop\TEST\BC.xlsx"

 'Tester si classeur source data  à filtrer est ouvert
    On Error Resume Next
    Workbooks(Vclas2).Activate

 ' Si une erreur est renvoyée, fichier non ouvert
    If Err.Number <> 0 Then

 'j'ouvre le fichier 2
     Application.FindFile
     Vclas2 = ActiveWorkbook.Name
    End If
    On Error GoTo 0

Windows(Vclas2).Activate

Sheets("Liste_CC").Select

        If Worksheets("Liste_CC").AutoFilterMode Then
             Worksheets("Liste_CC").AutoFilterMode = False
         End If

        [A1].AutoFilter

        Vfl = Range("A100000").End(xlUp).Row

        Range("A1").CurrentRegion.Select

        ActiveSheet.Range("$A$1:$I$" & Vfl).AutoFilter Field:=4, Criteria1:="=" & Vald, Operator:=xlAnd

        n = [Subtotal(3, A:A)] - 1 'nb lignes filtrées

            If n > 0 Then

                Range([A1], [A1].End(xlDown)).EntireRow.Select
                Selection.Copy Destination:=Workbooks(Vclas1).Sheets("CC").Rows("1:1")

                   Else
                MsgBox " Pas de donnees "

            End If
     Application.ScreenUpdating = True

'ferme le classeur source sans enregistrer
ActiveWorkbook.Close savechanges:=False

Windows(Vclas1).Activate
Sheets("TDB_Hebdo").Select

End Sub

Bonne journée ,

A

Parfait

J'utilise souvent un onglet tables pour y stocker mes listes et autres données fixes ou paramétrables. Un chemin critique peut aussi y être stocké

Bonne continuation

Cordialement

FINDRH