Discussion :

[Vba14]

Bonjour à toutes et à tous,
J'ai mis en place ce code qui devrait me permettre de copier la dernière ligne saisie vers un autre tableau en faisant un double-clic en fin de saisie,
mais malheureusement cela ne fonctionne pas et je ne trouve pas la source de mon erreur.
Les deux tableaux sont des tableaux structurés.

Serait-il possible de faire la copie au moment du changement de ligne par tabulation ?

Voici le code qui se trouve dans la feuille "Arch_Bât". Je vous joint également une partie de mon fichier pour exemple.
J'ai modifié le fichier joint afin qu'il soit plus léger et plus court.
Test.xlsm

Merci par avance pour l'aide que vous pourrez m'apporter.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
 
'Procédure de copie automatique des données saisies
'vers la feuille "Général" après un double-clique en fin de ligne après la saisie
 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Ligne_Cours As Long
Dim Nbre_Lignes_Max As Long
Application.ScreenUpdating = False
 
    'On désactive les filtres si il y en a
        On Error Resume Next
            ThisWorkbook.Sheets("Général").ShowAllData
        On Error GoTo 0
 
    'On affiche les lignes qui pourraient être masquées
        ThisWorkbook.Sheets("Général").Rows("1:1048576").EntireRow.Hidden = False
 
    'On cherche le nombre de lignes déjà remplies
        Nbre_Lignes_Max = ThisWorkbook.Sheets("Général").Range("Q1048576").End(xlUp).Row
 
    'Si il y a des références
        If Nbre_Lignes_Max > 1 Then
 
        'On parcoure la colonne Q en commençant par la fin
            For Ligne_Cours = Nbre_Lignes_Max To 1 Step -1
 
            'Si "DB" est trouvé
                If LCase(ThisWorkbook.Sheets("Général").Range("Q" & Ligne_Cours)) = "DB" Then
 
            'On insére une ligne après la dernière référence trouvée
                ThisWorkbook.Sheets("Général").Rows(Ligne_Cours + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                ThisWorkbook.Sheets("Général").Rows(Ligne_Cours + 1).Select
                    With Selection.Interior
                        .Pattern = xlNone
                        .TintAndShade = 0
                        .PatternTintAndShade = 0
                    End With
 
            'On complète la colonne "Q" avec la nouvelle ligne et les lettres "DB"
                ThisWorkbook.Sheets("Général").Range("Q" & Ligne_Cours + 1) = "DB"
 
                End If
            Exit Sub
 
        Next Ligne_Cours
        End If
Application.ScreenUpdating = True
End Sub

Test.xlsm

[Vba14]

Je reviens vers vous, personne n'a une petite idée !
Je suis vraiment très embêté, il ne me reste que cette partie pour terminer mon appli et je suis bloqué, quelle galère...
Je continu à chercher de mon côté.
Merci par avance

[Philippe Tulliez]

Bonjour,
Pour recevoir une aide, il faudrait clarifier "mais malheureusement cela ne fonctionne pas" car cela ne veut rien dire et de plus de nombreux contributeurs dont je fais partie n'ouvrent pas les pièces jointes.

[Vba14]

Bonjour Monsieur TULLIEZ,

Merci pour votre réponse.
Lorsque je clique après la dernière colonne saisie, la copie ne se fait pas.
Le curseur clignote dans la cellule de départ et c'est tout, rien d'autre pas de copie de la ligne vers le tableau de la feuille "Général".

Dans le cas de mon exemple, une recherche est faite dans le tableau de la feuille "Général" pour trouver la dernière ligne où se trouvent "DB" dans la colonne Q.
Ensuite, si c'est le cas, une ligne doit s'insérer en dessous de la dernière occurence afin de coller la ligne venant du tableau de la feuille "Arch_Bât", celle où j'ai fait un double-clic.
Désolé de ne pas avoir été plus précis.

[BENNASR]

Bonjour
Pour copier n'importe quelle ligne avec deux clic tester avec prudence

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Columns("A:P")) Is Nothing Then
Cancel = False
dlg = Sheets("Général").Range("A" & Sheets("Général").Rows.Count).End(xlUp).Row
If dlg < 1 Then dlg = 1
Range(Cells(Target.Row, "A"), Cells(Target.Row, "P")).Copy Sheets("Général").Range("A" & dlg + 1)
Cancel = True
End If
End Sub

[Vba14]

Bonjour BENNASR,

Merci pour votre réponse.
Par contre, il est impératif que la copie s'insert après la dernière occurence "DB" de la colonne Q de la feuille "Général"

Par contre, le code copie bien la ligne où je fais le double-clic.

[Philippe Tulliez]

Bonjour,

Dans le cas de mon exemple, une recherche est faite dans le tableau de la feuille "Général" pour trouver la dernière ligne où se trouvent "DB" dans la colonne Q.
Ensuite, si c'est le cas, une ligne doit s'insérer en dessous de la dernière occurence afin de coller la ligne venant du tableau de la feuille "Arch_Bât", celle où j'ai fait un double-clic.

Déjà, je ne comprends pas pourquoi vous cherchez la première ligne alors qu'à la fin de votre premier paragraphe, vous précisez "Les deux tableaux sont des tableaux structurés"
Etant donné qu'une procédure de tri permettra de ranger vos lignes comme bon vous semble, il n'y a aucune raison d'insérer des lignes. Je pense que vous vous compliquez la vie pour rien.

Pour connaître la dernière ligne d'un tableau structuré, c'est tout simplement objet.Rows.Count où "objet" représente la plage de données du tableau structuré

Exemple simple de la copie de la dernière ligne d'un tableaux structuré nommé t_Source vers la prochaine ligne libre d'un tableau structuré nommé t_Target
On suppose pour cet exemple que les colonnes des deux tableaux sont identiques et dans le même ordre, qu'il y a des données dans les deux tables, qu'il n'y a aucun filtre ni de ligne total dans la table "cible".
Il est préférable de faire un collage spécial-Valeur lorsque l'on copie des données vers une table structurée pour éviter de perdre notamment une mise en forme conditionnelle

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub CopyRow()
  Dim rngSource As Range
  Dim rngTarget As Range
  Set rngSource = Range("t_Source")
  Set rngTarget = Range("t_Target")
  ' Copie
  With rngSource
  .Rows(.Rows.Count).Copy
  End With
  ' Coller uniquement les valeurs
  With rngTarget
  .Rows(.Rows.Count + 1).PasteSpecial xlPasteValues
  End With
  Set rngSource = Nothing: Set rngTarget = Nothing
End Sub

il y a lieu évidemment de l'adapter pour que cela fonctionne dans une procédure événementielle et également vérifier qu'il y a bien des données dans les deux tableaux (pour insérer le cas échéant une ligne dans la table "cible"), de supprimer les filtres des deux tables et enlever le temps de la copie la ligne total du tableau "cible"

Pour ma part, je privilégie la copie par colonne plutôt qu'une ligne entière quand les tables n'ont pas toutes les mêmes colonnes et surtout dans un ordre différent.

[Vba14]

Merci pour votre réponse.
Je souhaite procéder de cette manière car dans la colonne Q de la feuille "Général", il peut y avoir DB, VC, CU, DET.
Donc selon le tableau sur lequel je travaille (il y en a donc 4) ils doivent tous avoir la même procédure.

Par exemple, il y a 1100 lignes où il y a DB dans la colonne Q, 3200 où il y a VC...

De plus, il est indispensable d'indiquer DB dans la colonne Q après le collage.

Je ne sais pas si c'est plus simple de faire un tri après chaque copier coller. Mais bon je ne suis pas un spécialiste en la matière

[Vba14]

Ce code de BENNASR fonctionne à peu prés bien.
J'y ai ajouté une ligne afin que DB se mette en colonne Q après le collage, ça fonctionne bien.
Il me faut donc soit faire un tri de la colonne Q après chaque saisie, soit insérer la copie après la dernière occurence DB trouvée dans la colonne Q

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.ScreenUpdating = False
    If Not Intersect(Target, Columns("A:P")) Is Nothing Then
    Cancel = False
dlg = Sheets("Général").Range("A" & Sheets("Général").Rows.Count).End(xlUp).Row
    If dlg < 1 Then dlg = 1
        Range(Cells(Target.Row, "A"), Cells(Target.Row, "P")).Copy Sheets("Général").Range("A" & dlg + 1)
        Sheets("Général").Range("Q" & dlg + 1) = "DB"
Cancel = True
    End If
Application.ScreenUpdating = True
End Sub

[Vba14]

Bonjour à toutes et à tous,

Je reviens vers vous avec mon problème car je n'ai toujours pas trouvé la solution.
J'ai essayé de faire un mixte avec mon code existant et celui proposé par BENNASR mais sans succès.

Je continue à chercher de mon côté, n'hésitez pas à me faire part de vos suggestions.
Merci par avance

[BENNASR]

Bonjour
personnellement comme bricoleur et autodidacte, je démarre l'enregistreur automatique des macros, je renomme le code fourni sur plateau
et dans l'ancien code je fais juste appelé ce code
ce qui donne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub trier()
'
 
 
    ActiveWorkbook.Worksheets("Général").ListObjects("Tableau1").Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("Général").ListObjects("Tableau1").Sort.SortFields. _
        Add Key:=Range("Tableau1[[#All],[Où]]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Général").ListObjects("Tableau1").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

et

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.ScreenUpdating = False
    If Not Intersect(Target, Columns("A:P")) Is Nothing Then
    Cancel = False
dlg = Sheets("Général").Range("A" & Sheets("Général").Rows.Count).End(xlUp).Row
    If dlg < 1 Then dlg = 1
        Range(Cells(Target.Row, "A"), Cells(Target.Row, "P")).Copy Sheets("Général").Range("A" & dlg + 1)
        Sheets("Général").Range("Q" & dlg + 1) = "DB"
Cancel = True
    End If
    ActiveWorkbook.Worksheets("Général").Activate
     Call trier
 
Application.ScreenUpdating = True
End Sub

[Vba14]

Bonjour BENNASR,

Merci pour votre réponse.
Donc vous partiriez plutôt sur le tri du tableau que par l'insertion d'une ligne ?

Je vais tenter cette approche.
Merci beaucoup

[Vba14]

Effectivement ça fonctionne de cette façon. Monsieur Tulliez avait raison depuis le début.
Merci à tous pour votre aide et votre participation
Bonne journée