Aide pour un code qui ne fonctionne pas

Version imprimable

1 pièce(s) jointe(s)

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.
Pièce jointe 636096

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

Code:

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

Pièce jointe 636096

21/03/2023, 12h31
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
21/03/2023, 12h35
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.
21/03/2023, 12h40
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.

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

Code:

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

21/03/2023, 13h53
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.

Bonjour,

Citation:

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:

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.

21/03/2023, 14h28
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

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:

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

22/03/2023, 08h17
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

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:

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

Code:

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

22/03/2023, 09h01
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
22/03/2023, 09h20
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