XL 2016 Validation d'une ligne et transfert de la ligne vers un autre classeur

[J@ba]

Bonjour, excusez moi de vous déranger je suis en train de créer une macro me permettant en double cliquant une cellule (L2) de copier la ligne (A2;K2) complète et de la transférer dans un autre classeur sur une ligne vide en commençant par la colonne A

 

[job75]

Bonsoir J@ba, bienvenue sur XLD,

Sans plus d'explications, essayez cette macro, à placer dans le code de la feuille :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column <> 12 Or Target.Row = 1 Then Exit Sub
Cancel = True
Dim fichier As Variant
fichier = Application.GetOpenFilename("Fichiers Excel(*.xls*),*.xls*")
If fichier = False Then Exit Sub
With Workbooks.Open(fichier).Sheets(1) 'ouvre le fichier choisi
    With .Cells(.Rows.Count, 1).End(xlUp)(2) '1ère cellule vide
        Target.EntireRow.Copy .Cells 'copier-coller
        Application.Goto .Cells 'affiche la cellule
    End With
End With
End Sub

A+

 

[J@ba]

Bonjour job75,

L'idée est d'avoir dans un dossier deux Excel sur un serveur connecté au pc, l'un avec un formulaire à remplir ( que j' ai déjà fait ) qui va me remplir automatiquement une seconde Sheets dans le premier Excel où la demande est enregistré et une fois que l'on valide la demande via la fonction du double-clique ces données validés sont transférer vers un second Excel où des données supplémentaire sont ajoutés.

Grace au code que vous m'avez fournit la sélection de la ligne et le double clic se fait mais j'ai un hic après, on me demande de selectionner un ecxel puis on me dit que le fichier est introuvable j'ai donc ajouté une ligne donnant la route d'accès au second excel mais je me retrouve avec la même erreur.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column <> 12 Or Target.Row = 1 Then Exit Sub
Cancel = True
Dim fichier As Variant
fichier = Application.GetOpenFilename("Fichiers Excel(*.xlsx*),*.xlsx*")
If fichier = False Then Exit Sub

 Dim Filamentpossible As String
MonDossier = "Z:\COMMUN_USINE\LISTINGS\Listing Impression 3D"
 
If Len(Dir(MonDossier, vbDirectory)) > 0 Then 'vérifie si le Dossier existe
   Shell Environ("WINDIR") & "\explorer.exe " & MonDossier, vbNormalFocus
End If
 
With Workbooks.Open("Listing impression").Sheets("liste impression") 'ouvre le fichier choisi
    With .Cells(.Rows.Count, 1).End(xlUp)(2) '1ère cellule vide
        Target.EntireRow.Copy .Cells 'copier-coller
        Application.Goto .Cells 'affiche la cellule
    End With
End With
End Sub

 

[job75]

Bonjour J@ba,,

Grace au code que vous m'avez fournit la sélection de la ligne et le double clic se fait mais j'ai un hic après, on me demande de selectionner un ecxel puis on me dit que le fichier est introuvable

Avec mon code je ne vois pas comment vous pouvez avoir un message disant que le fichier est introuvable alors que vous l'avez choisi.

Application.GetOpenFilename fonctionne sur PC avec Windows mais pas sur MAC.

A+

 

[J@ba]

Rectification, le excel avec le formulaire sera en fichier partagé sur one drive pour permettre une mise a jour constante ainsi qu'une messagerie pour notifier les personnes responsable de ce travail

 

[job75]

A ma connaissance les macros VBA ne fonctionnent pas sur SharePoint.

 

[J@ba]

Mince , du coup le programme fonctionne merci à vous

 

[J@ba]

en reprenant du coup ce que vous m'aviez donnez j'y ai ajouté une commande permettant lorsque je double-clic de passer la cellule en vert et si elle y est déjà de la repasser en blanc et ensuite de faire la commande que vous m'aviez fournit plus tôt mais petit hic . elle enleve le vert si il y en à mais n'en met pas si il y n'y en à pas

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column = 27 Then
 If Target.Interior.Pattern <> x1None Then
      Target.Interior.Pattern = x1None
      
    Else
    
 Select Case Target.Column
    Case 27 'colonne AA
        Target.Interior.Color = 5287936

End Select
End If
End If


If Target.Column <> 27 Or Target.Row = 1 Then Exit Sub
Cancel = True
Dim fichier As Variant
fichier = Application.GetOpenFilename("Fichiers Excel(*.xls*),*.xlsm*")
If fichier = False Then Exit Sub
With Workbooks.Open("Listing impression").Sheets("liste impressions") 'ouvre le fichier choisi
    With .Cells(.Rows.Count, 1).End(xlUp)(2) '1ère cellule vide
        Target.EntireRow.Copy .Cells 'copier-coller
        Application.Goto .Cells 'affiche la cellule
    End With
End With
End Sub

 

[job75]

Vos messages se suivent sans aucune cohérence, je vous laisse à vos élucubrations.