Problème ajout suppression de lignes.

**ericmicro** · 19/02/2014, 15h46

Bonjour,

Dans le classeur ci-joint, j'ai une macro qui historise dans la feuille "Histo_TRLT" les changement de "TRLT Total J/O" et "Date MAJ" effectué dans la feuille "Liste des onglets".

Le problème que je n'arrive pas à résoudre est le suivant:

Si dans la feuille "Liste des onglets" j'ai une ou plusieurs nouvelles lignes ou suppressions de lignes, j'aimerai recopier ou supprimer la/les lignes dans la feuille "Histo_TRLT".
Merci de votre aide.

ED

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
49
50
51
52
53
54
55
56
57
58
59
60
Private Sub Worksheet_Activate()
 
 
    'définition des variables
    Dim histo As String
    Dim TRLThisto As Integer
    Dim i As Integer
    Dim j As Integer
    Dim Derncol As Integer
    Dim Derncoltitre As Integer
 
 
 
j = 2 'N° ligne Liste des onglets
i = 2 'N° ligne Histo TRLT
 
Do While Cells(i, 2) <> ""
 
'recherche de  la premiere colonne vide par ligne ds la feuille Histo_TRLT
Derncol = (Cells(i, Cells.Columns.Count).End(xlToLeft).Column) + 1
 
 
 
histo = Cells(i, 1).Value 'récupère la valeur "Référence" de la feuille histo
 
TRLThisto = Cells(i, Derncol - 2) 'récupère la derniere valeur TRLT de la feuille histo
'MsgBox (TRLThisto)
 
 
While Sheets("Liste des onglets").Cells(j, 1) <> "" ' parcours le tableau de la feuille Liste des onglets
 
    If Sheets("Liste des onglets").Cells(j, 1) = histo And Sheets("Liste des onglets").Cells(j, 3) <> TRLThisto Then 'ne recupere les données que si differentes
        Cells(i, Derncol) = Sheets("Liste des onglets").Cells(j, 3) 'renvoie le TRLT dans la cellule de la premiere colonne vide de la ligne active de la feuille "Histo_TRLT
        Cells(i, Derncol + 1) = CDate(Sheets("Liste des onglets").Cells(j, 7)) 'renvoie la date dans la cellule de la deuxieme colonne vide de la ligne active de la feuille "Histo_TRLT
    End If
 
 
j = j + 1
'DernLigneliste = Sheets("Liste des onglets").Range("A" & Rows.Count).End(xlUp).Row 'compte les lignes de la liste des onglets
 
Wend
j = 2
i = i + 1
Loop
 
   Derncoltitre = Sheets("Histo_TRLT").UsedRange.Columns.Count 'recherche numero de la premiere colonne vide de la premiere ligne sur la feuille Histo_TRLT pour coller les titres
    'MsgBox (Derncoltitre)
 
    'copier coller des titres des deux colonnes
Range(Cells(1, Sheets("Histo_TRLT").UsedRange.Columns.Count - 3), Cells(1, Sheets("Histo_TRLT").UsedRange.Columns.Count - 2)).Select
Selection.Copy
Range(Cells(1, Sheets("Histo_TRLT").UsedRange.Columns.Count - 1), Cells(1, Sheets("Histo_TRLT").UsedRange.Columns.Count)).Select
ActiveSheet.Paste
     Application.CutCopyMode = False 'enleve la surbrillance copier
 
     Columns.AutoFit 'largeur de colonnes auto
 
    Range("A2").Select
 
End Sub

**Phil'oche** · 19/02/2014, 16h31

Excel ne propose pas, par défaut, d'interception des évènements "ajout" ou "suppression de ligne"

Pour contourner le problème, une solution :
- Ajouter dans ta feuille "liste des onglets" 2 boutons "Ajout ligne" et "Suppression ligne" qui vont déclencher du code VBA que tu pourras exploiter comme tu veux,

**ericmicro** · 19/02/2014, 16h46

Merci de votre réponse,
Je pensais pas à un évènement " ajout" ou "suppression de ligne", mais plutôt a un comparatif des deux feuilles.
Si la référence n'existe pas dans la feuille "Histo_TRLT", mais existe dans la feuille "Liste des onglets" alors on recopie la ligne dans "Histo_TRLT".
Inversement, si la référence existe dans la feuille "Histo_TRLT", mais n'existe plus dans la feuille "Liste des onglets" alors on supprime la ligne dans "Histo_TRLT".

**keygen08** · 19/02/2014, 20h08

Bonsoir
Vous pensez bien, c'est ce que je fais avec le code ci-dessous : a adpater

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
'masque les lignes dont les vacanciers sont masqué avec le n° de soin
dim L as range, r as integer 
'pour la plage suivante : je compte le nombre de ligne sinon a chaque ligne retiré c'est le brin ( la ligne 10 devenant 9....)
For R = 6 To Range("a1:a" & [c65000].End(xlUp).Row).Rows.Count
'je verifie que mon n° d'enregistrement est existant sur l'autre feuille
        Set L = Feuil62.Columns(4).Find(Cells(R, 1).Value, LookIn:=xlValues, lookat:=xlWhole)
        If L Is Nothing Then
            If R >= 6 Then
'si ce n'est pas le cas, j'efface la ligne
            Rows(R).Delete 
            Else: Exit For
            End If
        End If
Next R

je fais ensuite la comparaison inverse afin d'ajouter les n° d'enregistrement manquants.
Je me serais bien essayé sur votre fichier mais je n'arrive pas a l'ouvrir.

**ericmicro** · 20/02/2014, 11h57

Bonjour,
Voici mon fichier avec la formule pour la suppression des lignes qui n'existent plus dans la feuille "Liste des onglets".

Problème je n'arrive pas à faire l'inverse, import dans la feuille "Histo_TRLT" des nouvelles lignes de la feuille "Liste des onglets".

Si l'un d'entre vous a un solution ...

Merci,

ED

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
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
Private Sub Worksheet_Activate()
 
 
    'définition des variables
    Dim histo As String
    Dim TRLThisto As Integer
    Dim i As Integer
    Dim j As Integer
    Dim Derncol As Integer
    Dim Derncoltitre As Integer
 
 
 
j = 2 'N° ligne Liste des onglets
i = 2 'N° ligne Histo TRLT
 
 'module suppression des lignes qui n'existent plus dans la feuille "Liste des onglets"
Dim l As Range, r As Integer
 
For r = 2 To Range("a2:a" & [c65000].End(xlUp).Row).Rows.Count
 
Set l = Feuil2.Columns(1).Find(Cells(r, 1).Value, LookIn:=xlValues, lookat:=xlWhole)
 
If l Is Nothing Then
 
If r >= 2 Then
 
Rows(r).Delete
 
Else: Exit For
End If
End If
 
Next r
 
 
 
 
'module ajout des nouvelles colonnes TRLT et Date
 
Do While Cells(i, 2) <> ""
 
'recherche de  la premiere colonne vide par ligne ds la feuille Histo_TRLT
Derncol = (Cells(i, Cells.Columns.Count).End(xlToLeft).Column) + 1
 
 
 
histo = Cells(i, 1).Value 'récupère la valeur "Référence" de la feuille histo
 
TRLThisto = Cells(i, Derncol - 2) 'récupère la derniere valeur TRLT de la feuille histo
'MsgBox (TRLThisto)
 
 
While Sheets("Liste des onglets").Cells(j, 1) <> "" ' parcours le tableau de la feuille Liste des onglets
 
    If Sheets("Liste des onglets").Cells(j, 1) = histo And Sheets("Liste des onglets").Cells(j, 3) <> TRLThisto Then 'ne recupere les données que si differentes
        Cells(i, Derncol) = Sheets("Liste des onglets").Cells(j, 3) 'renvoie le TRLT dans la cellule de la premiere colonne vide de la ligne active de la feuille "Histo_TRLT
        Cells(i, Derncol + 1) = CDate(Sheets("Liste des onglets").Cells(j, 7)) 'renvoie la date dans la cellule de la deuxieme colonne vide de la ligne active de la feuille "Histo_TRLT
    End If
 
 
j = j + 1
'DernLigneliste = Sheets("Liste des onglets").Range("A" & Rows.Count).End(xlUp).Row 'compte les lignes de la liste des onglets
 
Wend
j = 2
i = i + 1
Loop
 
   Derncoltitre = Sheets("Histo_TRLT").UsedRange.Columns.Count 'recherche numero de la premiere colonne vide de la premiere ligne sur la feuille Histo_TRLT pour coller les titres
    'MsgBox (Derncoltitre)
 
    'copier coller des titres des deux colonnes
Range(Cells(1, Sheets("Histo_TRLT").UsedRange.Columns.Count - 3), Cells(1, Sheets("Histo_TRLT").UsedRange.Columns.Count - 2)).Select
Selection.Copy
Range(Cells(1, Sheets("Histo_TRLT").UsedRange.Columns.Count - 1), Cells(1, Sheets("Histo_TRLT").UsedRange.Columns.Count)).Select
ActiveSheet.Paste
     Application.CutCopyMode = False 'enleve la surbrillance copier
 
     Columns.AutoFit 'largeur de colonnes auto
 
    Range("A2").Select
 
End Sub

**keygen08** · 21/02/2014, 13h20

Bonjour, la suite

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
'module ajout des nouvelles colonnes TRLT et Date
With Sheets("trlt")
For r = 2 To .Range("a2:a" & .[c65000].End(xlUp).Row).Rows.Count
Set l = Columns(1).Find(Cells(r, 1).Value, LookIn:=xlValues, lookat:=xlWhole)
If l Is Nothing Then
If r >= 2 Then
.Rows(r).Copy Rows(r).Insert
'j'ai choisi de copier la ligne de trlt dans liste onglets.
Else: Exit For
End If
End If
Next r

N'arrivant pas a ouvrir les fichiers joints, je n'ai pus réaliser de test.

**ericmicro** · 24/02/2014, 12h43

Bonjour,
J'ai vraiment un problème de compréhension avec ce fichier.
Je n'arrive toujours pas à intégrer et faire fonctionner votre formule !!!

Pour le problème d'ouverture des fichiers joints, après test avec plusieurs PC pas de problème pour moi...

Salutations,

ED

**keygen08** · 25/02/2014, 12h44

Bonjour
Avec un peu de retard, travail oblige, et correction faite. j'ai mis volontairement tous le code.
La premiere partie supprime les ligne qui n'existe plus dans liste des onglets
la deuxieme partie ajoute les nouvelles lignes contenue dans liste des onglets.
la troisieme partie trie dans l'ordre alphabetique.

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
Private Sub Worksheet_Activate()
Dim l As Range, r As Integer
 
 'module suppression des lignes qui n'existent plus dans la feuille "Liste des onglets"
For r = 2 To Range("a2:a" & [c65000].End(xlUp).Row).Rows.Count
Set l = Feuil2.Columns(1).Find(Cells(r, 1).Value, LookIn:=xlValues, lookat:=xlWhole)
    If l Is Nothing Then
        If r >= 2 Then
        Rows(r).Delete
        Else: Exit For
        End If
    End If
Next r
 
'module ajout des nouvelles lignes TRLT et Date
'pour chaque valeur de liste onglet, colonne A
With Sheets("Liste des onglets")
For r = 2 To .[a65000].End(xlUp).Row
'on recherche la valeur dans histo
Set l = Columns(1).Find(.Cells(r, 1).Value, LookIn:=xlValues, lookat:=xlWhole)
'si elle n'est pas trouvé
    If l Is Nothing Then
'on insere une ligne
        Rows(r).Insert
'on colle dans cette ligne les valeur de liste des onglets
        Cells(r, 1) = .Cells(r, 1) 'Réference
        Cells(r, 4) = .Cells(r, 7) 'Date MAJ
        Cells(r, 3) = .Cells(r, 3) 'trlt J/O
    End If
Next r
End With
 
'trie dans l'ordre alphabetique
With ActiveWorkbook.Worksheets("Histo_TRLT").Sort
        .SetRange Range("A1:J" & [a65000].End(xlUp).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
end sub

**ericmicro** · 25/02/2014, 18h02

Un immense merci à toi keygen08,

Tout fonctionne correctement dans le code.

Grâce à des gens comme toi je vais peut-être finir par être autonome avec VBA (y a encore du boulot !!!... )

Plus qu'a mettre en "Résolu".

Merci encore pour tous,

Eric

Ps:ci joint mon fichier avec mes fonctions et modifs

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
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
Private Sub Worksheet_Activate()
Dim l As Range, r As Integer
 
 'module suppression des lignes qui n'existent plus dans la feuille "Liste des onglets"
For r = 2 To Range("a2:a" & [c65000].End(xlUp).Row).Rows.Count
Set l = Feuil2.Columns(1).Find(Cells(r, 1).Value, LookIn:=xlValues, lookat:=xlWhole)
    If l Is Nothing Then
        If r >= 2 Then
        Rows(r).Delete
        Else: Exit For
        End If
    End If
Next r
 
 
 
 
'module: ajout dans "Histo_TRLT" des nouvelles lignes presentent dans "Liste des onglets"
With Sheets("Liste des onglets")
For r = 2 To .[a65000].End(xlUp).Row
'on recherche la valeur dans histo
Set l = Columns(1).Find(.Cells(r, 1).Value, LookIn:=xlValues, lookat:=xlWhole)
'si elle n'est pas trouvé
    If l Is Nothing Then
'on insere une ligne
        Rows(r).Insert
'on colle dans cette ligne les valeur de liste des onglets
        Cells(r, 1) = .Cells(r, 1) 'Réference
        Cells(r, 2) = .Cells(r, 2) 'Désignation
        Cells(r, 4) = .Cells(r, 7) 'Date MAJ
        Cells(r, 3) = .Cells(r, 3) 'trlt J/O
    End If
Next r
End With
 
 
'définition des variables
    Dim histo As String
    Dim TRLThisto As Integer
    Dim i As Integer
    Dim j As Integer
    Dim Derncol As Integer
    Dim Derncoltitre As Integer
 
    j = 2 'N° ligne Liste des onglets
    i = 2 'N° ligne Histo TRLT
 
'module ajout des nouvelles colonnes TRLT et Date
 
Do While Cells(i, 2) <> ""
 
'recherche de  la premiere colonne vide par ligne ds la feuille Histo_TRLT
Derncol = (Cells(i, Cells.Columns.Count).End(xlToLeft).Column) + 1
 
 
 
histo = Cells(i, 1).Value 'récupère la valeur "Référence" de la feuille histo
 
TRLThisto = Cells(i, Derncol - 2) 'récupère la derniere valeur TRLT de la feuille histo
'MsgBox (TRLThisto)
 
 
While Sheets("Liste des onglets").Cells(j, 1) <> "" ' parcours le tableau de la feuille Liste des onglets
 
    If Sheets("Liste des onglets").Cells(j, 1) = histo And Sheets("Liste des onglets").Cells(j, 3) <> TRLThisto Then 'ne recupere les données que si differentes
        Cells(i, Derncol) = Sheets("Liste des onglets").Cells(j, 3) 'renvoie le TRLT dans la cellule de la premiere colonne vide de la ligne active de la feuille "Histo_TRLT
        Cells(i, Derncol + 1) = CDate(Sheets("Liste des onglets").Cells(j, 7)) 'renvoie la date dans la cellule de la deuxieme colonne vide de la ligne active de la feuille "Histo_TRLT
    End If
 
 
j = j + 1
'DernLigneliste = Sheets("Liste des onglets").Range("A" & Rows.Count).End(xlUp).Row 'compte les lignes de la liste des onglets
 
Wend
j = 2
i = i + 1
Loop
 
   Derncoltitre = Sheets("Histo_TRLT").UsedRange.Columns.Count 'recherche numero de la premiere colonne vide de la premiere ligne sur la feuille Histo_TRLT pour coller les titres
    'MsgBox (Derncoltitre)
 
    'copier coller des titres des deux colonnes
Range(Cells(1, Sheets("Histo_TRLT").UsedRange.Columns.Count - 3), Cells(1, Sheets("Histo_TRLT").UsedRange.Columns.Count - 2)).Select
Selection.Copy
Range(Cells(1, Sheets("Histo_TRLT").UsedRange.Columns.Count - 1), Cells(1, Sheets("Histo_TRLT").UsedRange.Columns.Count)).Select
ActiveSheet.Paste
     Application.CutCopyMode = False 'enleve la surbrillance copier
 
     Columns.AutoFit 'largeur de colonnes auto
 
 
 
 
 
 
'trie dans l'ordre alphabetique
Columns("a:a").Select
ActiveWorkbook.Worksheets("Histo_TRLT").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Histo_TRLT").Sort.SortFields.Add Key:=Range("a1"), SortOn:=xlSortOnValues, Order:=xlAscending ', DataOption:=xlsorttextasnumber
With ActiveWorkbook.Worksheets("Histo_TRLT").Sort
        .SetRange Range("A1:IV" & [a65000].End(xlUp).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
End Sub

Problème ajout suppression de lignes. [XL-2007]

Macros et VBA Excel

Discussions similaires

Partager

Partager