Discussion :

[pheonix00fr]

Bonjour,
J’aurais besoin d’aide pour mettre au point un projet que je crée.
J’ai un classeur avec quatre feuilles (Liste, tab1, tab2 et tab3), dans Liste j’ai un tableau de B5 à F500. Je l’alimente au fur et à mesure et je voudrais copier-coller les nouvelles lignes dans les tableaux des autres feuilles en fonction de la valeur des cellules D, E et F du tableau de Liste. Pour envoyer la ligne vers la feuille,
Tab1, il faut « X » dans la cellule D,
Tab2, il faut « X » dans la cellule E,
Tab3, il faut « X » dans la cellule F,
Les trois, deux ou une de ces cellules peuvent avoir la valeur X.

Merci de votre aide.

[Nako_lito]

faut que tu te fasse une boucle sur toute les lignes des ton tableau principal et que tu regarde la cellule ("D" & i), ("E" & i), ("F" & i). Si c'est différent que chaine vide, tu copie la cellule ("A" & i) et tu colle dans le classeur correspondant.
La feuille excel porte le nom = numéro de colonne - 3.

Un exemple rapide :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Public Sub toto()
    Dim x, i, j, r As Integer
 
    x = ThisWorkbook.Sheets("Liste").UsedRange.Rows.Count
    For i = 1 To x 'parcourir toute les lignes de la feuille LISTE
        For j = 4 To 6 'parcourir les colonnes D, E, F
            If LCase(ThisWorkbook.Sheets("Liste").Cells(i, j).Value) = "x" Then 'si y'a une correspondance dans la cellule i,j 
                r = ThisWorkbook.Sheets("Tab" & j - 3).Range("A25000").End(xlUp).Row + 1 'récupère la dernière ligne + 1 du Tab concerné
                ThisWorkbook.Sheets("Tab" & j - 3).Range("A" & r).Value = ThisWorkbook.Sheets("Liste").Range("A" & i).Value 'copie la valeur qui est dans LISTE vers TAB
            End If
        Next
    Next
End Sub

[eric4459]

Bonjour Phoenix,
Où places-tu les lignes copiées dans les onglets tab1, 2 et 3? J'ai considéré l'hypothèse que les données sont collées en colonne B.
Je suis en train d'écrire un code et j'ai supposé qu'il y avait déjà des lignes sur ces feuilles, mon code permettra de coller les nouvelles lignes à la suite.
Eric

[pheonix00fr]

Merci pour ton aide, voici le fichier de base pour mieux "voir".

[eric4459]

Bonsoir Phoenix,
J'ai vu ton fichier trop tard pour pouvoir modifier le mien, mais en gros si tu suis en pas à pas tu devrais pouvoir saisir ce que j'ai voulu faire et tu pourras l'adapter si cela te convient. (Grand week-end pour moi dés ce soir )
J'ai mis un compteur en H1 de l'onglet LISTE, ici mis à 25 pour mes tests, lors de l'ajout de nouvelles lignes sur cet onglet se sera ma référence.
En espérant que ce que j'ai fait soit assez clair.
Eric
Code

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
Option Explicit
 Sub Mise_à_Jour()
 
 
    Dim wks1 As Worksheet
    Dim wks2 As Worksheet
    Dim wks3 As Worksheet
    Dim wks4 As Worksheet
    Dim i As Integer
    Dim j As Integer
    Dim EndOfCell As Long
    Dim nblig1 As Long
    Dim nblig2 As Long
    Dim nblig3 As Long
    Dim nblig4 As Long
    Dim nblig5 As Long
    Dim Plage As String
    Set wks1 = ThisWorkbook.Worksheets("Liste")
    Set wks2 = ThisWorkbook.Worksheets("tab1")
    Set wks3 = ThisWorkbook.Worksheets("tab2")
    Set wks4 = ThisWorkbook.Worksheets("tab3")
 
    With wks1
        nblig1 = Range("B1").End(xlDown).Row
    End With
 
    With wks2
        nblig3 = wks2.Range("B1").End(xlDown).Row
    End With
 
    With wks3
        nblig4 = wks3.Range("B1").End(xlDown).Row
    End With
 
    With wks4
        nblig5 = wks4.Range("B1").End(xlDown).Row
    End With
 
     Application.ScreenUpdating = False
 
    If nblig1 > Range("H1").Value Then
    Range("B" & Range("H1").Value + 1).Activate
    Cells(ActiveCell.Row, 2).EntireRow.Insert
    Range("B" & Range("H1").Value + 2).Activate
    nblig2 = Range("B" & Range("H1").Value + 3).End(xlDown).Row
    MsgBox ((nblig2 - (Range("H1") + 1)) & " nouvelle(s)ligne(s) ajoutée(s)")
    Range("B" & Range("H1") + 2).Select
    End If
    'i = (Range("H1") + 2)
    j = 0
    EndOfCell = nblig2
 
    For i = (Range("H1") + 2) To EndOfCell
        If Range("D" & i) = "X" Then
        Range("B" & i).Select
        Range(Selection, Selection.End(xlToRight)).Copy
        wks2.Range("B" & (nblig3 + j)).PasteSpecial
        End If
        If Range("D" & i + 1) = "X" Then
        j = j + 1
        Else
        j = j
        End If
    Next i
 
    j = 0
    For i = (Range("H1") + 2) To EndOfCell
        If Range("E" & i) = "X" Then
        Range("B" & i).Select
        Range(Selection, Selection.End(xlToRight)).Copy
        wks3.Range("B" & (nblig4 + j)).PasteSpecial
        End If
        If Range("E" & i + 1) = "X" Then
        j = j + 1
        Else
        j = j
        End If
    Next i
 
    j = 0
    For i = (Range("H1") + 2) To EndOfCell
        If Range("F" & i) = "X" Then
        Range("B" & i).Select
        Range(Selection, Selection.End(xlToRight)).Copy
        wks4.Range("B" & (nblig5 + j)).PasteSpecial
        End If
        If Range("F" & i + 1) = "X" Then
        j = j + 1
        Else
        j = j
        End If
    Next i
 
    Range("B" & Range("H1").Value + 1).Activate
    Cells(ActiveCell.Row, 2).EntireRow.Delete
 
    Range("H1") = nblig1
    Range("H2") = nblig2 - 1
    Application.CutCopyMode = False
    MsgBox ("Terminé")
     Application.ScreenUpdating = True
   End Sub

Fichier Joint: Copier nouvelles lignes.xlsm

[pheonix00fr]

Je nage complet, je n'arrive pas à la faire fonctionner.
Si j'ai bien compris la macro compte les lignes du tableau et calcule si il y a une différence avec le dernier comptage, mais j'ai souvent des erreurs sur le nombre de lignes ajoutés, parfois pour une ajouté elles m’en trouvent plus de 1048545 (un peu beaucoup). Le problème de cette méthode c'est que si la valeur "X" est ajouté dans une les cellules D E ou F d'une ligne déjà existante le transfert ver les autres ne se fera pas.
Quand j’ajoute des valeurs dans le tableau, que le compteur ne s’affole pas et que la cellule contient bien la valeur X le transfert ne se fait pas.



Le fichier avec la macro

[pheonix00fr]

J'ai trouvé la solution a mon problème.
Merci à tous pour votre aide.

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
Private Sub Worksheet_Activate()
 
li = Sheets("LISTE").Range("B5").End(xlDown).Row
If Sheets("LISTE").Range("B6") = "" Then Exit Sub
'If Sheets("LISTE").Range("B6") = "" Then MsgBox "Pas de données saisies!", vbCritical: Exit Sub
If Sheets("LISTE").Range("B7") = "" Then li = 7
ligne = 4
 
For i = 4 To li
    If UCase(Sheets("LISTE").Range("D" & i)) = "X" Then
    Cells(ligne, 2) = Sheets("LISTE").Cells(i, 2)
    Cells(ligne, 3) = Sheets("LISTE").Cells(i, 3)
 
ligne = ligne + 1
End If
 
Next
 
End Sub

[Nako_lito]

petite précision sur ton cas quand même.

ce morceau de code me parait suspect :

Code :

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

1
2
3
4
li = Sheets("LISTE").Range("B5").End(xlDown).Row
If Sheets("LISTE").Range("B6") = "" Then Exit Sub
'If Sheets("LISTE").Range("B6") = "" Then MsgBox "Pas de données saisies!", vbCritical: Exit Sub
If Sheets("LISTE").Range("B7") = "" Then li = 7

qu'est ce que tu cherche a trouver comme valeur pour "li" ?

par ce qu'avec ce que tu marque, si tu fais ton .range("B5").End(xlDown).Row et qu'il te retourne qqc > 7, c'est que B6 et B7 sont vide donc pas besoin de faire les deux tests suivant.

Je te conseillerai de réviser la nécessité de ce morceau là, après, je sais pas comment est fait ton fichier, mais ça me parait étrange quand même.

[MarcelG]

Bonjour à vous, Bonjour au Forum,

Tout d’abord quelques remarques

1 - Nako_lito
Ta déclaration initiale de variables

Code :

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

  Dim x, i, j, r As Integer

Signifie que seule r est de type Integer, les autres étant de type Variant

2 - Si l’on travaille sur un même classeur, la désignation de l’objet ThisWorkbook à chaque ligne de procédure est inutile.
Les objets feuille étant par défaut ceux du classeur actif
A défaut, préciser

Code :

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

ThisWorkbook.Activate

3 - Pour désigner la dernière cellule, mieux vaut raisonner en End(xlToleft) et End(xlUp) plutôt que End(xlToright) et End(xlDown) ;
Ce afin d’éviter le piège des cellules vides intermédiares.

4 -La précision

Code :

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

Option Compare Text

placée en début de module évite de préciser les majuscules et les minuscules si cette différence n'importe pas

5 - Enfin, sauf votre respect, je trouve vos codes un peu compliqués.

Je propose (à adapter éventuellement)

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
Option Compare Text
Option Explicit
 
Public Sub copie_phoenix()
 
Dim wkl As Worksheet
Dim i As Integer, j As Integer
Dim d As Integer
Dim rcop As Range
Dim lafeuille As Worksheet
 
Set wkl = Worksheets("Liste")
 
With wkl
        d = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
 
'balayage des lignes de la feuille Liste
For i = 1 To d
    'balayage des 3 colonnes D, E, F de la feuille Liste
    For j = 4 To 6
        'affectation de la feuille correspondante
        Set lafeuille = Worksheets("Tab" & j - 3)
        'test valeur
        If wkl.Cells(i, j) = "x" Then
            With lafeuille
                'adresse de la cellule où les données sont recopiées
                Set rcop = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
                'recopie des valeurs
                .Range(rcop, rcop.Offset(0, 5)).Value = wkl.Range(wkl.Cells(i, j).Offset(0, 1 - j), wkl.Cells(i, j).Offset(0, 6 - j)).Value
            End With
        End If
        Set lafeuiile = Nothing
    Next j
Next i
 
Set wkl = Nothing
 
End Sub

N'hésitez pas à revenir.

[Nako_lito]

MarcelG,

Pour le point 1-

On m'a dit le contraire sur un autre post ou les gens étaient bien aggressif d'ailleurs, mais effectivement, tu as raison, et je ne fais jamais ça d'habitude.

Pour le point 2-

Je banni .activate, .select ou tout autre codage s'en rapprochant dans mes codes. Tout simplement par ce que les premiers temps ou j'ai utilisé ça, les utilisateurs revenaient systématiquement pour me dire que çà plantait dans tous les sens. Sitôt que tu as deux classeurs ouvert en même temps et qu'ils lancent un macro, un saut sur l'autre classeur avec la souris et c'est le bazar.
Donc, certes, le thisworkbook est inutile si il n'y a qu'un classeur actif, mais par expérience, je l'utilise systématiquement. et quand ça devient trop lourd, je set une variable comme tu l'as fais qui fait référence a la feuille voulu dans thisworkbook et basta.

Pour en revenir à la syntaxe sur le point 1 et 2 :

Bien que je sois entièrement d'accord avec ta manière de coder, normalement j'aurais pondu la même chose, ou qqc de très proche; sur les 3 lignes de code que j'ai présenté, je pensais être peinard au vu de la dernière prise de tête que j'ai eu sur un autre sujet ou les gens faisaient la courses au nombre de lignes utilisée vs ma manière initiale de coder, mais je me rends compte qu'on peut pas plaire à tout le monde ici et quoi qu'on fasse, il y aura toujours quelqu'un qui va venir analyser le code des autres pour montrer qu'il a la plus grosse. Pourquoi faire ? Sérieusement ...
C'est pas contre toi, encore une fois, j'approuve à 200% ce que tu as fourni.

[MarcelG]

Salut Nako,

et quoi qu'on fasse, il y aura toujours quelqu'un qui va venir analyser le code des autres pour montrer qu'il a la plus grosse. Pourquoi faire ? Sérieusement ...

Je ne comprends pas trop ton langage (ou je n'ose pas).

Quoi qu'il en soit, le but de ce forum est de proposer et d'échanger des dévelopementss non seulement utiles aux demandeurs mais aussi à toute le communauté.
Une seule condition : que ledemandeur se donne la peine de
1- chercher avant de poster toutes les solutions par tous les moyens
Je l'ai dit et répété, en VBA comme en mathématiques, c'est la recherche qui paie.
2 - comprendre le code proposé et revenir autant de fois que nécessaire pour comprendre et apprendre.
3 - mettre son orgueil de côté (moi-même, par le passé, je me suis fait reprendre de nombreuses fois, parfois sévèrement, avant d'entretenir les meilleurs rapports)

J'en viens au code

Il faut prendre du recul par rapport à l'enregistreur en supprimant le supperflu (notamment ces f.. Select).
Cependant, l'activation, si elle est opportune, est tout à fait justifiée.

As-tu essayé mon code? Qu'en penses-tu?
As-tu des questions?

Au plaisir.