Couper coller une ligne selon condition sur un autre classeur

Bonjour,

Je recherche de l'aide
Alors tout d'abord, sachez que j'ai un niveau très bas sur Excel, mais par la force des choses et à la lectures de nombreux post sur le net j'ai pu réussir des petites manipulations dont je suis fière. En revanche, concernant la manipulation dont il s'agit aujourd'hui, je ne peux pas inventer des lignes de codes et j'appelle donc à l'aide.

En PJ vous trouverez deux classeurs:

-Un classeur analyse avec le récapitulatif de toutes les analyses de tous les produits.

-un classeur produit y ou sont archiver toutes les analyses du produit y.

Ce que je souhaite :

J'aimerais créer une macro qui lorsque je cliquerais sur le bouton MAJ de mon classeur produit y toutes les lignes produit y duclasseur analyse soit couper coller sur mon classeur produit y ( afin d'être archivé, et supprimer du classeur analyse)

Pouvez-vous m'aider sur cette question s'il vous plait ?

Evidemment je suis preneuse de tout : Solution, conseils,

Je vous en remercie par avance
Cordialement

Bonjour Saarraa, bonjour le forum,

Si les deux classeurs se trouvent dans le même dossier le code ci-dessous fonctionnera.

Le code :

Private Sub CommandButton1_Click()
Dim CD As Workbook 'déclare la variable CD (Claseur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CS As Workbook 'déclare la variable CS (Claseur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)

Set CD = ThisWorkbook 'définit le classur destination CD
Set OD = CD.Worksheets("RECAP RESULTATS") 'définit l'onglet destination OD
CA = CD.Path & "\" 'de'finit le chemin d'accès CA
Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST (première cellule vide de la colonne A de l'onglet OD)
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set CS = Workbooks("analyse.xlsm") 'définit le classeur source CS (génère une erreur si ce classeur n'est pas ouvert)
If Err > 0 Then 'condition : si une erreur a été générée
    Err.Clear 'supprime l'erreur
    Set CS = Workbooks.Open(CA & "analyse.xlsm") 'définit le classeut source en l'ouvrant
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs
Set OS = CS.Worksheets("Analyse") 'définit l'onglet source OS
DL = OS.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet source OS
OS.Range("A3:BS" & DL).Copy DEST 'copy la plage A3:BS... de l'onglet source et la colle dans DEST
OS.Range("A3:BS" & DL).ClearContents 'efface le contenu de la plage A3:BS...
OS.Rows(3 & ":" & DL).Delete 'suprime les lignes de l'onglet OS de la ligne 3 à la ligne DL
CS.Close True 'ferme le classeur source CS en enregistrant les modifications (facultatif si tu veux garder ce classeur ouvert, supprime cette ligne)
End Sub

Ton fichier modifié :

Hello,

Autre possibilité.

R@g

Salut Saaarraa,
Salut l'équipe,

si j'ai compris l'affaire, il semblerait que tu aies plusieurs produits ayant chacun leur fichier RECAP...
Déjà, ici, si je suis à côté, pas besoin d'ouvrir le fichier car ce ne sera pas bon !

- Partant de ce principe, je te propose de placer la commande de MÁJ dans le fichier 'Analyse', histoire de ne copier le code qu'une seule fois ;
- pas de bouton MAJ mais, dans le fichier 'Analyse', un double-clic en colonne [B:B] pour sélectionner le produit à exporter ;
- une confirmation de sécurité plus tard, la macro cherche le fichier 'Produit' correspondant, l'ouvre si nécessaire et effectue le transfert ;

- pour les besoins du tri des données, j'ai du supprimer tes colonnes [B:C] en mode tableau structuré ;
- je t'ai mis une macro de tri :
* un clic sur la ligne d'en-tête trie la BDD selon cette colonne ;
* une sélection de plusieurs cellules dans la ligne d'en-tête permet un tri avec 2 KEY : Key1 = la colonne correspondant à la première cellule de la sélection, Key2 = la colonne correspondant à la dernière cellule de la sélection.

N'ayant guère de précisions et encore moins de certitude quand à la règle de construction des noms de fichiers-produits, ce code ne fonctionnera que avec les fichiers-exemple fournis que tu auras la bonne idée de placer dans le même répertoire !

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim sWBk As Workbook, iRow1%, iRow2%, iOK%
'
If Not Intersect(Target, Columns(2)) Is Nothing And Target.Row > 1 And Target <> "" Then
    Cancel = True
    If MsgBox("Transfert des analyses " & Target & " ?", vbQuestion + vbYesNo, "Analyse - Info") = vbYes Then
        Range("A2:BS" & Range("A" & Rows.Count).End(xlUp).Row).Sort _
            key1:=[A3], order1:=xlDescending, _
            key2:=[B3], order2:=xlAscending, _
            Orientation:=xlTopToBottom, Header:=xlYes
        iRow1 = Columns(2).Find(what:=Target, lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext).Row
        iRow2 = Columns(2).Find(what:=Target, lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlPrevious).Row
        sItem = LCase(Replace(Target, " ", "-"))
        For Each sWKb In Workbooks
            If InStr(sWKb.Name, sItem) = 1 Then _
                iOK = 1: _
                Exit For
        Next
        If iOK = 0 Then Set sWKb = Workbooks.Open(ThisWorkbook.Path & "\" & sItem & ".xlsm")
        With sWKb.Sheets(1)
            .Rows(3 & ":" & 3 + (iRow2 - iRow1)).Insert shift:=xlDown
            Range("A" & iRow1 & ":BS" & iRow2).Copy Destination:=.Range("A3:BS" & 3 + (iRow2 - iRow1))
            Range("A" & iRow1 & ":BS" & iRow2).Delete shift:=xlUp
        End With
        Range("A2:BS" & Range("A" & Rows.Count).End(xlUp).Row).Sort key1:=[A3], order1:=xlDescending, Orientation:=xlTopToBottom, Header:=xlYes
    End If
End If
'
End Sub

A+

Salut l’équipe, je vous remercie pour votre aide

curilis57, Merci merci je sais pas comment vous remercier c’est exactement ce que je voulais !

Ça fait des semaines que je cherchais une solution vous m’avez était d’une aide précieuse, vous êtes trop fort 💪🏼👌🏼

Salut Sara,

3 façons de transférer tes analyses pour le prix (gratuit) d'une !
- par double-clic comme précédemment pour TOUS les produits X ;
- par clic-droit pour UNE analyse, ainsi que tu viens de me le demander

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'
Dim iRow1%, iRow2%, sItem$
'
If Not Intersect(Target, Columns(2)) Is Nothing And Target.Row > 1 And Target <> "" Then
    Cancel = True
    If MsgBox("Transfert des analyses " & Target & " ?", vbQuestion + vbYesNo, "Analyse - Info") = vbYes Then
        iRow1 = Target.Row
        iRow2 = iRow1
        sItem = LCase(Replace(Target, " ", "-"))
        Call Transfert(sItem, iRow1, iRow2)
    End If
End If
'
End Sub

- par une sélection ciblée pour deux ou plusieurs analyses contigües .
Si cette option ne t'est absolument pas nécessaire, tu repères le code suivant dans la Private Sub Worksheet_SelectionChange(ByVal Target As Range) et tu l'effaces.

If Not Intersect(Target, Columns(2)) Is Nothing And Target.Row > 1 And Selection.Rows.Count > 1 And Selection.Columns.Count = 1 Then
    If MsgBox("Transfert des analyses " & Selection.Cells(1, 1) & " ?", vbQuestion + vbYesNo, "Analyse - Info") = vbYes Then
        iRow1 = Selection.Row
        iRow2 = Selection.Row + Selection.Rows.Count - 1
        sItem = LCase(Replace(Selection.Cells(1, 1), " ", "-"))
        Call Transfert(sItem, iRow1, iRow2)
    End If
End If

Bonne année !

A+