Extraire des données de plusieurs feuilles avec deux conditions vers une autre feuille

nini623

Habitué
Bonjour,

J'ai enregistrée une macro afin de pouvoir extraire des données de plusieurs feuilles vers une seule si une données d'une colonne correspond à deux conditions différentes.
Bon, je ne sai pas si je m'explique bien mais voilà :
j'ai une base de données de documents classés par feuilles : j'ai donc une feuille "Ancien systeme", une feuille "Procedure", une feuille "Instruction", une feuille "Formulaire" et une feuille "Liste".
Chacune des feuilles contiennent les même informations au niveau des colonnes : "A=Référence", "B=Ancienne Référence", "C=TITRE", "E=Rédacteur", "F=Service Emetteur".....plein d'autres colonnes mais qui ne m'intéresse pas dans l'extraction....et enfin, "S=Date de fin de validité" et "T= Obsolete", sauf pour la feuille "Ancien systeme" dont la colonne A est vide!
Je souhaite donc extraite les données des colonnes que j'ai nommés ci-dessus vers une autre feuille que j'appellerais "liste des obso" en donnant comme conditions que "OBSO" ou "FUTUR OBSO" soit dans la colonne "T=Obsolete" et que chaque extraction arrive à la suite de l'autre.
C'est à dire que l'extraction qui sera faite de la feuille ancien systeme soit en premier, que l'extraction de la feuille Procedure arrive à la première ligne vide et ainsi de suite.

Code:
Sub Macro1()
'
' Macro1 Macro
'

'
    Rows("5:500").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("A5").Select
    Sheets("Ancien Systeme").Select
    ActiveSheet.Range("$B$1:$W$10").AutoFilter Field:=18, Criteria1:="<>"
    ActiveWindow.SmallScroll Down:=-18
    ActiveWindow.SmallScroll ToRight:=-3
    Range("R3:S10").Select
    ActiveWindow.SmallScroll ToRight:=-9
    Range("R3:S10,B3:E10").Select
    Range("E3").Activate
    Selection.Copy
    Sheets("Liste des Obso").Select
    Range("B5").Select
    ActiveSheet.Paste
    Range("A12:G12").Select
    Application.CutCopyMode = False
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Sheets("Ancien Systeme").Select
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 12
    ActiveWindow.ScrollColumn = 13
    ActiveWindow.ScrollColumn = 14
    ActiveWindow.ScrollColumn = 15
    ActiveWindow.ScrollColumn = 16
    ActiveWindow.ScrollColumn = 17
    ActiveWindow.ScrollColumn = 18
    ActiveWindow.ScrollColumn = 19
    ActiveSheet.Range("$B$1:$W$10").AutoFilter Field:=18
    Sheets("Procedure").Select
    ActiveSheet.Range("$A$1:$X$293").AutoFilter Field:=20, Criteria1:="<>"
    ActiveWindow.SmallScroll Down:=-24
    Range("S6:T267").Select
    ActiveWindow.ScrollColumn = 16
    ActiveWindow.ScrollColumn = 15
    ActiveWindow.ScrollColumn = 14
    ActiveWindow.ScrollColumn = 13
    ActiveWindow.ScrollColumn = 12
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollRow = 175
    ActiveWindow.ScrollRow = 159
    ActiveWindow.ScrollRow = 152
    ActiveWindow.ScrollRow = 149
    ActiveWindow.ScrollRow = 132
    ActiveWindow.ScrollRow = 119
    ActiveWindow.ScrollRow = 113
    ActiveWindow.ScrollRow = 111
    ActiveWindow.ScrollRow = 108
    ActiveWindow.ScrollRow = 101
    ActiveWindow.ScrollRow = 98
    ActiveWindow.ScrollRow = 93
    ActiveWindow.ScrollRow = 89
    ActiveWindow.ScrollRow = 88
    ActiveWindow.ScrollRow = 78
    ActiveWindow.ScrollRow = 68
    ActiveWindow.ScrollRow = 67
    ActiveWindow.ScrollRow = 61
    ActiveWindow.ScrollRow = 56
    ActiveWindow.ScrollRow = 54
    ActiveWindow.ScrollRow = 49
    ActiveWindow.ScrollRow = 47
    ActiveWindow.ScrollRow = 43
    ActiveWindow.ScrollRow = 37
    ActiveWindow.ScrollRow = 28
    ActiveWindow.ScrollRow = 25
    ActiveWindow.ScrollRow = 17
    ActiveWindow.ScrollRow = 6
    ActiveWindow.SmallScroll Down:=-9
    Range("A6:F267").Select
    Range("F6").Activate
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 12
    ActiveWindow.ScrollRow = 175
    ActiveWindow.ScrollRow = 158
    ActiveWindow.ScrollRow = 151
    ActiveWindow.ScrollRow = 150
    ActiveWindow.ScrollRow = 132
    ActiveWindow.ScrollRow = 122
    ActiveWindow.ScrollRow = 113
    ActiveWindow.ScrollRow = 111
    ActiveWindow.ScrollRow = 108
    ActiveWindow.ScrollRow = 102
    ActiveWindow.ScrollRow = 100
    ActiveWindow.ScrollRow = 93
    ActiveWindow.ScrollRow = 88
    ActiveWindow.ScrollRow = 77
    ActiveWindow.ScrollRow = 69
    ActiveWindow.ScrollRow = 67
    ActiveWindow.ScrollRow = 62
    ActiveWindow.ScrollRow = 61
    ActiveWindow.ScrollRow = 56
    ActiveWindow.ScrollRow = 54
    ActiveWindow.ScrollRow = 49
    ActiveWindow.ScrollRow = 46
    ActiveWindow.ScrollRow = 43
    ActiveWindow.ScrollRow = 38
    ActiveWindow.ScrollRow = 28
    ActiveWindow.ScrollRow = 25
    ActiveWindow.ScrollRow = 17
    ActiveWindow.ScrollRow = 5
    Range("A6:F267,S6:T267").Select
    Range("S6").Activate
    Selection.Copy
    Sheets("Liste des Obso").Select
    Cells(Range("K1"), 1).Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=48
    Range("A63:G63").Select
    Application.CutCopyMode = False
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Sheets("Procedure").Select
    ActiveSheet.Range("$A$1:$X$293").AutoFilter Field:=20
    Sheets("Instruction").Select
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 12
    ActiveWindow.ScrollColumn = 13
    Columns("S:U").Select
    Selection.EntireColumn.Hidden = False
    ActiveSheet.Range("$A$1:$Y$224").AutoFilter Field:=20, Criteria1:="<>"
    ActiveWindow.SmallScroll Down:=-24
    Range("S7:T168").Select
    ActiveWindow.ScrollColumn = 12
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.SmallScroll Down:=-72
    Range("S7:T168,A7:F168").Select
    Range("F7").Activate
    Selection.Copy
    Sheets("Liste des Obso").Select
    Cells(Range("K1") + 1, 1).Select
    ActiveSheet.Paste
    Sheets("Instruction").Select
    ActiveWindow.SmallScroll ToRight:=9
    ActiveSheet.Range("$A$1:$Y$224").AutoFilter Field:=20
    Sheets("Liste des Obso").Select
    ActiveWindow.SmallScroll Down:=42
    Range("A100:G100").Select
    Application.CutCopyMode = False
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Sheets("Liste").Select
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 12
    ActiveWindow.ScrollColumn = 13
    ActiveWindow.ScrollColumn = 14
    ActiveWindow.ScrollColumn = 15
    ActiveWindow.ScrollColumn = 16
    ActiveWindow.ScrollColumn = 17
    ActiveWindow.ScrollColumn = 16
    Columns("R:T").Select
    Selection.EntireColumn.Hidden = False
    ActiveSheet.Range("$A$1:$V$64").AutoFilter Field:=19, Criteria1:="<>"
    ActiveWindow.SmallScroll Down:=-27
    Range("R7:S49").Select
    ActiveWindow.ScrollColumn = 15
    ActiveWindow.ScrollColumn = 14
    ActiveWindow.ScrollColumn = 13
    ActiveWindow.ScrollColumn = 12
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 4
    Range("R7:S49,A7:E49").Select
    Range("E7").Activate
    Selection.Copy
    Sheets("Liste des Obso").Select
    Cells(Range("K1") + 2, 1).Select
    ActiveSheet.Paste
    Sheets("Liste").Select
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 12
    ActiveWindow.ScrollColumn = 13
    ActiveWindow.ScrollColumn = 14
    ActiveWindow.ScrollColumn = 15
    ActiveSheet.Range("$A$1:$V$64").AutoFilter Field:=19
    Sheets("Liste des Obso").Select
    ActiveWindow.ScrollRow = 94
    ActiveWindow.ScrollRow = 92
    ActiveWindow.ScrollRow = 90
    ActiveWindow.ScrollRow = 87
    ActiveWindow.ScrollRow = 85
    ActiveWindow.ScrollRow = 81
    ActiveWindow.ScrollRow = 79
    ActiveWindow.ScrollRow = 76
    ActiveWindow.ScrollRow = 73
    ActiveWindow.ScrollRow = 70
    ActiveWindow.ScrollRow = 68
    ActiveWindow.ScrollRow = 65
    ActiveWindow.ScrollRow = 62
    ActiveWindow.ScrollRow = 60
    ActiveWindow.ScrollRow = 57
    ActiveWindow.ScrollRow = 55
    ActiveWindow.ScrollRow = 53
    ActiveWindow.ScrollRow = 51
    ActiveWindow.ScrollRow = 49
    ActiveWindow.ScrollRow = 48
    ActiveWindow.ScrollRow = 45
    ActiveWindow.ScrollRow = 44
    ActiveWindow.ScrollRow = 42
    ActiveWindow.ScrollRow = 41
    ActiveWindow.ScrollRow = 39
    ActiveWindow.ScrollRow = 38
    ActiveWindow.ScrollRow = 36
    ActiveWindow.ScrollRow = 35
    ActiveWindow.ScrollRow = 34
    ActiveWindow.ScrollRow = 33
    ActiveWindow.ScrollRow = 32
    ActiveWindow.ScrollRow = 31
    ActiveWindow.ScrollRow = 30
    ActiveWindow.ScrollRow = 28
    ActiveWindow.ScrollRow = 27
    ActiveWindow.ScrollRow = 26
    ActiveWindow.ScrollRow = 25
    ActiveWindow.ScrollRow = 23
    ActiveWindow.ScrollRow = 22
    ActiveWindow.ScrollRow = 21
    ActiveWindow.ScrollRow = 20
    ActiveWindow.ScrollRow = 19
    ActiveWindow.ScrollRow = 18
    ActiveWindow.ScrollRow = 17
    ActiveWindow.ScrollRow = 16
    ActiveWindow.ScrollRow = 15
    ActiveWindow.ScrollRow = 14
    ActiveWindow.ScrollRow = 13
    ActiveWindow.ScrollRow = 12
    ActiveWindow.ScrollRow = 11
    ActiveWindow.ScrollRow = 10
    ActiveWindow.ScrollRow = 9
    ActiveWindow.ScrollRow = 8
    ActiveWindow.ScrollRow = 7
    ActiveWindow.ScrollRow = 6
    ActiveWindow.ScrollRow = 5
    Columns("A:A").Select
    Application.CutCopyMode = False
    Selection.Hyperlinks.Delete
    Range("A2").Select
End Sub
Voici le programme mais je pense qu'il doit y avoir une solution beaucoup plus simple que celle là.
En fait j'ai enregistré une suite de réalisation manuelle dans les différentes feuilles.
J'ai essayé de faire avec la fonction filtre élaboré mais je ne dois pas faire comme il faut car il me dit qua la plage n'est pas valide....

vous verrez aussi que j'ai essayé de mettre une ligne de séparation entre chaque type de documents mais ça ne marche pas parfaitement non plus....

Merci beaucoup pour votre aide.

virginie
 

zeb

Modérateur
Salut,

Rhoooolala !

Ca se voit que tu t'es laissée guider par l'enregistreur de macro.
C'est un très bon début. Mais il manque le reste : le nettoyage du code.
Par exemple, les scrolls sont inutiles.
Or sur 392 lignes, on en trouve 214 ! :ouch:

Par principe, on s'interdit d'utiliser le presse-papier comme mémoire temporaire.
C'est une zone partagée entre toutes les applications du système. Imagine que tous les programmes en fassent autant.
Bonjour la pagaille. On va voir comment faire autrement.

Tu jongles entre plusieurs feuilles, et tu comptes sur le système pour que la feuille, la cellule que tu sélectionnes restent actives.
C'est faire fort confiance à Windows et Excel. Au moindre "popeupètvousur", ta macro est plantée.

Par ailleurs, tu sélectionnes tel objet puis tu agis sur la sélection. Ben et si tu agissais directement sur l'objet ?
Exemple :
Code:
' // Pas terrible
Rows("5:500").Select
Selection.Delete Shift:=xlUp

' // Plus simple, plus logique, plus petit, plus... mieux
Rows("5:500").Delete
(J'ai aussi viré le Shift inutile puisque très intelligemment, tu as utilisé Rows())

Ensuite, je voudrais bien savoir pourquoi tu fais des filters et des masquages de colonnes au fur et à mesure.

Bon, je te laisse nous proposer un code un peu nettoyé.
Ensuite le programme c'est : te montrer comment ne pas passer par le presse-papier en utilisant mieux la méthode Copy() et comment désigner tes objets sans passer par des sélections.
 

nini623

Habitué



Merci zeb,
Je me mets au travail et je reviens te montrer le résultat.

Oui, je travaille avec l'enregistreur de macro car j'ai eu une formation où l'on m'a beaucoup expliqué avec ce système. Je souhaitais une formation sur le language afin de mieux s'avoir l'appréhender et l'utiliser avant mais trop cher....
merci pour l'info du presse-papier, je ne savais pas.
Mais je vois que je suis pas si nulle que je le pensais, ça fait plaisir à lire et ça donne confiance.

Pour la question des filtres, c'est que dans cette colonne, je ne veux extraire que les données des lignes où il y a écrit "OBSO" ou "FUTUR OBSO" donc les cases de la colonne "obsolète" ne sont pas vide. Mais dans ces lignes, je ne veux à nouveau que extraire certaines colonnes, pas la ligne entière.

Je vais déjà faire ce que tu me dis et je te montre ce que ça donne début de semaine prochaine.
 

nini623

Habitué
bon, comme ça me titille d'avancer sur ce sujet, j'ai essayé de "nettoyer" mon code :

Code:
Sub Actualiser()
'
' Macro1 Macro
'

'
    Rows("5:500").Delete
    Range("A5").Select
    Sheets("Ancien Systeme").Select
    ActiveSheet.Range("$B$1:$W$10").AutoFilter Field:=18, Criteria1:="<>"
    Range("R3:S10").Select
    Range("R3:S10,B3:E10").Select
    Range("E3").Activate
    Selection.Copy
    Sheets("Liste des Obso").Select
    Range("B5").Select
    ActiveSheet.Paste
    Sheets("Ancien Systeme").Select
    ActiveSheet.Range("$B$1:$W$10").AutoFilter Field:=18
    Sheets("Procedure").Select
    ActiveSheet.Range("$A$1:$X$293").AutoFilter Field:=20, Criteria1:="<>"
    Range("S6:T267").Select
    Range("A6:F267").Select
    Range("F6").Activate
    Range("A6:F267,S6:T267").Select
    Range("S6").Activate
    Selection.Copy
    Sheets("Liste des Obso").Select
    Cells(Range("K1"), 1).Select
    ActiveSheet.Paste
    Sheets("Procedure").Select
    ActiveSheet.Range("$A$1:$X$293").AutoFilter Field:=20
    Sheets("Instruction").Select
    Columns("S:U").Select
    Selection.EntireColumn.Hidden = False
    ActiveSheet.Range("$A$1:$Y$224").AutoFilter Field:=20, Criteria1:="<>"
    Range("S7:T168").Select
    Range("S7:T168,A7:F168").Select
    Range("F7").Activate
    Selection.Copy
    Sheets("Liste des Obso").Select
    Cells(Range("K1") + 1, 1).Select
    ActiveSheet.Paste
    Sheets("Instruction").Select
    ActiveSheet.Range("$A$1:$Y$224").AutoFilter Field:=20
    Sheets("Liste des Obso").Select
    Sheets("Liste").Select
    Columns("R:T").Select
    Selection.EntireColumn.Hidden = False
    ActiveSheet.Range("$A$1:$V$64").AutoFilter Field:=19, Criteria1:="<>"
    Range("R7:S49").Select
    Range("R7:S49,A7:E49").Select
    Range("E7").Activate
    Selection.Copy
    Sheets("Liste des Obso").Select
    Cells(Range("K1") + 2, 1).Select
    ActiveSheet.Paste
    Sheets("Liste").Select
    ActiveSheet.Range("$A$1:$V$64").AutoFilter Field:=19
    Sheets("Liste des Obso").Select
    Columns("A:A").Select
    Application.CutCopyMode = False
    Selection.Hyperlinks.Delete
    Range("A2").Select

End Sub

J'ai aussi enlevé l'histoire de mettre une ligne entre chaque extraction d'une feuille mais je n'ai pas dû enlever tout ce qu'il faut car il me mets encore une ligne mais vide cette fois entre chaque.
Je continue de regarder pour améliorer encore tout ça ;)
 

zeb

Modérateur
Ah.... :)
Tu as cet état d'esprit que j'aime tant et qui me fait continuer sur ce forum.

Juste pour faire joli, ajoute le langage à ta balise : [code=VB][/code].
 

zeb

Modérateur
Prenons le premier block.
Code:
Rows("5:500").Delete                                                   ' // De quelle feuille ?
Range("A5").Select                                                     ' // Pour quoi faire ?
Sheets("Ancien Systeme").Select                                        ' // zeb à dit : pas de select
ActiveSheet.Range("$B$1:$W$10").AutoFilter Field:=18, Criteria1:="<>"  ' // A revoir
Range("R3:S10").Select                                                 ' // Pour quoi faire ?
Range("R3:S10,B3:E10").Select                                          ' // Cette zone n'est pas fixe !!!!!!!
Range("E3").Activate                                                   ' // Pour quoi faire ?
Selection.Copy                                                         ' // zeb à dit : mieux utiliser la fonction Copy
Sheets("Liste des Obso").Select                                        ' // zeb à dit : pas de select
Range("B5").Select                                                     ' // zeb à dit : pas de select
ActiveSheet.Paste                                                      ' // zeb à dit : pas de presse-papier

Comme on a plusieurs feuilles, on va explicitement les nommer.
Code:
' // Préparation
Dim f_as As Worksheet ' // Feuille Ancient Système
Dim f_lo As Worksheet ' // Feuille liste des obso
Dim f_my As Worksheet ' // Feuille mystère ???

Set f_as = Worksheets("Ancien Systeme")
Set f_lo = Worksheets("Liste des Obso")
Set f_my = ActiveSheet

' // Début
f_my.Rows("5:500").Delete

Bon, dans ton code, le filtre te permet de faire "disparaître" des lignes.
Mais la zone R3:S10,B3:E10 est calculé par Excel en fontion du filtre quand tu joues avec ta souris. Pas par macro !!!!
Il va falloir faire nous même cette manip'.
(D'où l'intérêt de ne pas faire de filtre par macro, d'où ma surprise d'en trouver dans ton code)

Q1) Quelle est la zone susceptible de contenir tes données à copier ?
Q2) Quel critère pour choisir une ligne ?
Q3) Quelles colonnes copier ?

Bon, admettons que la réponse à Q1 soit A1:W500
Pour Q2, c'est "OBSO" ou "FUTUR OBSO", disons dans la colonne R. (Mais ce pourrait être "une valeur dans la colonne J" par exemple.)
Pour l'exemple, on peut dire A, C, E, G :spamafote:

Or donc, on va parcourir toute la zone, ligne par ligne.
Pour chaque ligne on va vérifier si elle nous intéresse.
Puis on va la copier dans la liste des obso'.

Là en core un peu de préparation : où copier ?
Code:
Dim cible As Range

Set cible = f_lo.Range("A1") '// Peut être voudrais-tu commencer plus bas que la première ligne ?
Code:
Dim ligne   as Range ' // 1 ligne
Dim acopier as Range ' // Les cellules à copier

For Each ligne In f_as.Rows("1:500")
    ' // La 18ème cellule d'une ligne est dans la colonne R    
    If ligne.Cells(18).Value like "*OBSO" Then
        ' //                            A               C               E               G
        Set acopier = Union(ligne.Cells(1), ligne.Cells(3), ligne.Cells(5), ligne.Cells(7))
        acopier.Copy Destination:=cible
        Set cible = cible.Offset(1)
    End If
Next

Et voilà !
Étudie bien mon exemple. Et généralise pour ton cas.
Regarde bien cette histoire de "cible".
J'attends tes commentaires, tes questions et ton code revu et corrigé.

Pour le prix de 0€, tu vas l'avoir ta formation ;)
(Mais t'as maintenant des devoirs à faire :lol: )
 

nini623

Habitué
ok pour le code, je vais faire mieux avec mon prochain devoir à corriger! :D

là maintenant le plus dur sera d'attendre lundi de retourner au boulot pour me plonger dans tout ce que tu viens de m'apprendre!!!!!! :pt1cable:
le week end va être long du coup!!!:lol:

et merci, j'apprécie vraiment le coup de main pour comprendre ce que je suis en train d'essayer d'écrire! ;)
 

nini623

Habitué
Bonjour Zeb,

voilà, je me retrouve bloquée par un message erreur mais je ne comprends pas ce qu'il veut exactement :

Code:
Sub Actualiser()
'
' // Préparation

Dim f_pr As Worksheet ' // Feuille Procedure
Dim f_in As Worksheet ' // Feuille Instruction
Dim f_fr As Worksheet ' // Feuille Formulaire
Dim f_li As Worksheet ' // Feuille Liste
Dim f_lo As Worksheet ' // Feuille liste des obso

Set f_pr = Worksheets("Procedure")
Set f_in = Worksheets("Instruction")
Set f_fr = Worksheets("Formulaire")
Set f_li = Worksheets("Liste")
Set f_lo = ActiveSheet

Dim cible As Range
Dim cible = f_lo.Range ("A5") ' j'ai ce message à ce niveau là :"Erreur de compilation Attendu : fin d'instruction"
Dim ligne As Range
Dim acopier As Range


' // Début

   f_lo.Rows("5:500").Delete
   For Each ligne In f_pr.Rows("1:500")
        If ligne.Cells(19).Value Like "*OBSO" Then
        Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18))
        acopier.Copy Destination:=cible
        Set cible = cible.Offset(1)
    End If
Next

End Sub

Je voulais essayer si ce début marchait mais avec ce message erreur, je n'arrive pas à aller plus loin....

Tu verras que pour le moment, j'ai laissé tomber la feuille ancien système qui de toute façon ne comporte que 5 lignes et je peux facilement les inclure en fin de tableau quand la macro marchera pour les autres feuiles.
Je vais essayer de comprendre déjà ça et je la compliquerais par la suite!
en espérant ne pas trop te décevoir....
 

zeb

Modérateur
Oh, c'est dommage d'avoir été bloquée par si peu. :(
Remplace *évidemment* Dim par Set à la ligne 18 et continue.

Tu aurais pu le voir quand même :o
Tu remarqueras que j'ai lâchement édité mon message pour ne pas qu'on voit que l'erreur venait de moi
(ne pas cliquer sur spoiler)

Pour le reste, il me semble que tu as bien compris.

Où enregistres-tu cette fonction ? Dans le code d'une feuille, du classeur, d'un module ?

Dans VBA/Excel, regarde un peu l'aide sur l'Option Explicit et si ce n'est pas encore fait, utilise-la.


A te lire.
 

nini623

Habitué


:lol: promis, je n'ai pas lu ton spoiler!! :lol:

J'enregistre cette fonction dans un module et j'ai créé un bouton dans la feuille "liste des obso" auquel j'ai relié la macro. C'est bien ou il y a mieux à faire?

Je ne connaissais pas l'option explicit, je m'en vais de ce pas voir ce que c'est et continuer le code! :)
 

zeb

Modérateur
Ton code est associé à ta feuille "Liste des obso". Alors mets-le donc là !
Ou bien laisse-le là où il est, ce n'est pas plus mal :spamafote:

Mais par contre, la ligne 15, ce n'est pas bon !
Par principe, Il ne faut pas faire confiance à ce qui est actif à un moment donné.
Code:
Set f_lo = ActiveSheet
Je te laisse corriger ça.

Pour info, si tu avais mis ta fonction dans le code de la feuille, tu aurais pu utiliser le mot-clef me qui se rapporte à la feuille, et ainsi te dispenser de déclarer f_lo. C'est un point de détail. Mais puisque tu es là pour apprendre... ;)
 

nini623

Habitué
Bon, je dois faire un truc qui ne va pas....
j'ai mis le code dans la feuille et j'ai donc utilisé le mot clé Me.
J'ai donc supprimé le module existant.
Mais j'ai dû supprimer quelque chose qu'il ne fallait pas....:??:

Voici mon code :

Code:
Sub Actualiser()
'
' // Préparation

Dim f_pr As Worksheet ' // Feuille Procedure
Dim f_in As Worksheet ' // Feuille Instruction
Dim f_fr As Worksheet ' // Feuille Formulaire
Dim f_li As Worksheet ' // Feuille Liste

Set f_pr = Worksheets("Procedure")
Set f_in = Worksheets("Instruction")
Set f_fr = Worksheets("Formulaire")
Set f_li = Worksheets("Liste")

Dim cible As Range
Set cible = Me.Range("A5")
Dim ligne As Range
Dim acopier As Range


' // Début

Me.Rows("5:500").Delete
For Each ligne In f_pr.Rows("1:500")
    If ligne.Cells(19).Value Like "*OBSO" Then
    Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18))
    acopier.Copy Destination:=cible
    Set cible = cible.Offset(1)
End If
Next
For Each ligne In f_in.Rows("1:500")
    If ligne.Cells(19).Value Like "*OBSO" Then
    Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18))
    acopier.Copy Destination:=cible
    Set cible = cible.Offset(1)
End If
Next
For Each ligne In f_fr.Rows("1:500")
    If ligne.Cells(19).Value Like "*OBSO" Then
    Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18))
    acopier.Copy Destination:=cible
    Set cible = cible.Offset(1)
End If
Next
For Each ligne In f_li.Rows("1:500")
    If ligne.Cells(19).Value Like "*OBSO" Then
    Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18))
    acopier.Copy Destination:=cible
    Set cible = cible.Offset(1)
End If
Next
End Sub
 

nini623

Habitué
j'ai remis le code dans un module, histoire déjà de comprendre ce qui ne va pas.
ensuite j'essaierais de simplifier.
je suis en train de chercher ce qui cloche en même temps et j'apprend les définitions de certains termes pour comprendre à quoi ils servent car j'avoue que la fonction "Set cible = cible.Offset(1)" m'étais inconnue....

Code:
Option Explicit

Sub Actualiser()
'
' // Préparation


Dim f_pr As Worksheet ' // Feuille Procedure
Dim f_in As Worksheet ' // Feuille Instruction
Dim f_fr As Worksheet ' // Feuille Formulaire
Dim f_li As Worksheet ' // Feuille Liste
Dim f_lo As Worksheet ' // Feuille Liste des Obso

Set f_pr = Worksheets("Procedure")
Set f_in = Worksheets("Instruction")
Set f_fr = Worksheets("Formulaire")
Set f_li = Worksheets("Liste")
Set f_lo = Worksheets("Liste des Obso")

Dim cible As Range
Set cible = f_lo.Range("A5")
Dim ligne As Range
Dim acopier As Range


' // Début


f_lo.Rows("5:500").Delete
For Each ligne In f_pr.Rows("1:500")
    If ligne.Cells(19).Value Like "*OBSO" Then
    Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18))
    acopier.Copy Destination:=cible
    Set cible = cible.Offset(1)
End If
Next
For Each ligne In f_in.Rows("1:500")
    If ligne.Cells(19).Value Like "*OBSO" Then
    Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18))
    acopier.Copy Destination:=cible
    Set cible = cible.Offset(1)
End If
Next
For Each ligne In f_fr.Rows("1:500")
    If ligne.Cells(19).Value Like "*OBSO" Then
    Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18))
    acopier.Copy Destination:=cible 'j'ai le message erreur d'exécution '1004' la méthode Copy de la classe Range a échoué
    Set cible = cible.Offset(1)
End If
Next
For Each ligne In f_li.Rows("1:500")
    If ligne.Cells(19).Value Like "*OBSO" Then
    Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18))
    acopier.Copy Destination:=cible
    Set cible = cible.Offset(1)
End If
Next
End Sub
 

zeb

Modérateur
Oh malheur ! :(
Ligne 21, on définit Cible du côté de la ligne 5.
Ligne 29, on atomise toutes les lignes, de la première à la cinq-centième, en explosant donc Cible.

Une solution toute simple : définir Cible après le Delete !
 

nini623

Habitué
salut zeb,

ça marche, mais à moitié.
Il me place bien les données de la feuille formulaire et Liste mais pas les données les données des deux premières feuilles.

Code:
Option Explicit

Sub Actualiser()
'
' // Préparation


Dim f_pr As Worksheet ' // Feuille Procedure
Dim f_in As Worksheet ' // Feuille Instruction
Dim f_fr As Worksheet ' // Feuille Formulaire
Dim f_li As Worksheet ' // Feuille Liste
Dim f_lo As Worksheet ' // Feuille Liste des Obso

Set f_pr = Worksheets("Procedure")
Set f_in = Worksheets("Instruction")
Set f_fr = Worksheets("Formulaire")
Set f_li = Worksheets("Liste")
Set f_lo = Worksheets("Liste des Obso")

'nettoyage de la feille

f_lo.Rows("5:500").Delete

' définition de la cible

Dim cible As Range
Set cible = f_lo.Range("A5")
Dim ligne As Range
Dim acopier As Range

For Each ligne In f_pr.Rows("1:500")
    If ligne.Cells(19).Value Like "*OBSO" Then
    Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18), ligne.Cells(19))
    acopier.Copy Destination:=cible
    Set cible = cible.Offset(1)
    End If
Next
For Each ligne In f_in.Rows("1:500")
    If ligne.Cells(19).Value Like "*OBSO" Then
    Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18), ligne.Cells(19))
    acopier.Copy Destination:=cible
    Set cible = cible.Offset(1)
    End If
Next
For Each ligne In f_fr.Rows("1:500")
    If ligne.Cells(19).Value Like "*OBSO" Then
    Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18), ligne.Cells(19))
    acopier.Copy Destination:=cible
    Set cible = cible.Offset(1)
    End If
Next
For Each ligne In f_li.Rows("1:500")
    If ligne.Cells(19).Value Like "*OBSO" Then
    Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18), ligne.Cells(19))
    acopier.Copy Destination:=cible
    Set cible = cible.Offset(1)
    End If
Next
End Sub
 

zeb

Modérateur
Salut,

>> ça marche,
Ah... :)

>> mais à moitié.
Ohhh :(

--------

Respecte bien le principe d'indentation. Par exemple, tes lignes 33, 34, 35 doivent être tabulées une fois de plus.
Oui, je sais, c'est du pinaillage. Mais n'es-tu pas là pour apprendre :à

--------

Mets l'instruction Stop (va voir dans l'aide à quoi elle sert. Je me dis que tu peux quand même deviner ;) ) entre les lignes 37 et 38.
Relance. Et arrête ta macro. Ceci pour se concentrer sur la première partie du code.

Vérifie que tu as bien des lignes qui contiennent "OBSO" dans la cellule 19, sans espace après, etc.
Fais-toi un classeur de test pour en être sûr. Ajoute une ligne 1 que tu rempliras à la main et apprends à déboguer toute seule (*) :

______
(*) Je reste là, hein ;)
 

nini623

Habitué
hello!!

:) voilà, tout le programme marche!
je suis super contente d'avoir réussi, merci beaucoup pour ton aide si précieuse!!! ;)

j'ai juste une dernière question, sur un autre fichier, j'ai créé une autre macro qui marche, grâce à ce que j'ai appris ici!
mais j'ai voulu y incure un bouton "QUITTER" pour femer le fichier ouvert. Sauf que biensûr, j'ai mis "application.quit" donc il me ferme tous les fichiers excel ouvert ....
Il faut que je définisse mon fichier et ensuite que je lui dise de le fermer, c'est ça?
 

nini623

Habitué
finalement, j'ai autre chose à te demander.....:ange:

voilà, j'ai utilisé le code dans un autre fichier semblable mais on m'a demandé de pouvoir trier les documents par service émetteur et par condition. J'ai immédiatement pensé à inclure deux autres userform avec combobox pour utiliser une liste de choix et aller copier les réponses dans la feuille et utiliser ces réponses comme données d'entrée de mon tri en colonne L et M.
Mon soucis est le bout de code " If ligne.Cells(20).Value Like "*OBSO" Then" car j'aimerais qu'il aille chercher la valeur a un endroit donné et non pas la définir directement dans le code et lui ajouter le choix du service émetteur.
L'endroit donné étant défini grâce à mes userform 10 et 11 dans le code.

Code:
Private Sub CommandButton8_Click()
'
' // Préparation


Dim f_pr As Worksheet ' // Feuille Procedure
Dim f_in As Worksheet ' // Feuille Instruction
Dim f_fr As Worksheet ' // Feuille Formulaire
Dim f_li As Worksheet ' // Feuille Liste
Dim f_lo As Worksheet ' // Feuille Extraction Obso

Set f_pr = Worksheets("Procedure")
Set f_in = Worksheets("Instruction")
Set f_fr = Worksheets("Formulaire")
Set f_li = Worksheets("Liste")
Set f_lo = Worksheets("Extraction Obso")

'nettoyage de la feille

f_lo.Rows("2:500").Delete

'définition des valeurs service et condition
UserForm10.Show '// mets la valeurs de la condition en L2 de la Feuille Extraction Obso
UserForm11.Show '// mets la valeurs du service émetteur en M2 de la Feuille Extraction Obso

' définition de la cible

Dim cible As Range
Set cible = f_lo.Range("A2")
Dim ligne As Range
Dim acopier As Range

For Each ligne In f_pr.Rows("1:500")
    If ligne.Cells(20).Value Like "*OBSO" Then
        Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(5), ligne.Cells(6), ligne.Cells(19), ligne.Cells(20))
        acopier.Copy Destination:=cible
        Set cible = cible.Offset(1)
    End If
Next

For Each ligne In f_in.Rows("1:500")
    If ligne.Cells(20).Value Like "*OBSO" Then
        Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(5), ligne.Cells(6), ligne.Cells(19), ligne.Cells(20))
        acopier.Copy Destination:=cible
        Set cible = cible.Offset(1)
    End If
Next
For Each ligne In f_fr.Rows("1:500")
    If ligne.Cells(19).Value Like "*OBSO" Then
        Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18), ligne.Cells(19))
        acopier.Copy Destination:=cible
        Set cible = cible.Offset(1)
    End If
Next
For Each ligne In f_li.Rows("1:500")
    If ligne.Cells(19).Value Like "*OBSO" Then
        Set acopier = Union(ligne.Cells(1), ligne.Cells(2), ligne.Cells(3), ligne.Cells(4), ligne.Cells(5), ligne.Cells(18), ligne.Cells(19))
        acopier.Copy Destination:=cible
        Set cible = cible.Offset(1)
    End If
Next
Sheets("Extraction Obso").Select
    Range("A1").Select
    UserForm1.Hide
End Sub
 

zeb

Modérateur
Salut,

Eh, moi aussi je suis content que ça marche :)

Douillou spique angliche ?
Parce que quitter, ça se dit to quit et fermer, ça se dit to close.

Or toi, tu ne veux pas quitter l'application, tu veux fermer ton classeur. Alors tu prends ton classeur (tip: c'est un workbook) et tu le fermes.

-----------------------------

Bon, je suis informaticien et je n'aime vraiment pas faire deux fois la même chose. Alors quand je vois que nous faisons 4 fois la même choses... argggh ! X_x

Regarde ça :
Code:
Dim feuille As Worksheet
For Each feuille In Array(f_pr, f_in, f_fr, f_li)
    For Each ligne In feuille.Rows("1:500")
        If ligne.Cells(20).Value Like "*OBSO" Then
            Set acopier = Nothing
            For Each i In Array(1, 2, 3, 5, 6, 19, 20)
                Set acopier = IIf(acopier Is Nothing, ligne.Cells(i), Union(acopier, ligne.Cells(i)))
            Next
            acopier.Copy Destination:=cible
            Set cible = cible.Offset(1)
        End If
    Next
Next

Bon, il y a une monstruosité dans ce code. C'est le Rows("1:500"). D'où sort ce 500 ?
(Si je lève le lièvre, c'est que j'ai des trucs à te montrer ;) T'es toujours là pour apprendre ?)

-----------------------------

Bon, donc attention. Le code proposé avec l'opérateur Like est encore un truc de [strike]fainéant[/strike]informaticien pour ne pas trop en écrire. LIKE "*MOT" signifie : qui se termine par "MOT". Or maintenant, ce mot est à chercher dans une cellule, ce n'est pas pareil.

Il faudra écrire : Value = "MOT"
Où est MOT ?
Dans une cellule :
Code:
Value = feuille.Range("Xn")
Dans une variable :
Code:
Dim Xn As String
Value = Xn

Qu'est-ce que le service émetteur ?
Une autre colonne ?
Bon :
Code:
If ligne.Cells(20).Value = "MOT" And ligne.Cells(autre_colonne).Value = "service émetteur" Then ..
 

nini623

Habitué
yes, i speak english very well ( :/ ) but sometimes my blonde highlights stand out....:D
avec un close, ça va beaucoup mieux.....:ange:

"Bon, il y a une monstruosité dans ce code. C'est le Rows("1:500"). D'où sort ce 500 ?
(Si je lève le lièvre, c'est que j'ai des trucs à te montrer T'es toujours là pour apprendre ?)"


OUI OUI, je suis toujours là pour apprendre! of course!!!!
le 500, c'est juste pour sélectionner un certains nombre de ligne..... et j'ai pris large pour être sûre de tout sélectionner....

Pour une question d'estétique du fichier, je démarre ma macro d'une feuille qui s'appelle Menu dans laquelle j'ai placé un bouton relié à cette macro.

Pour la condition et le service émetteur, je les place grâce à combobox dans les cellules L2 et M2 de la feuille "Extraction Obso" ou f_lo puisse que nous l'avons définie ainsi.
Donc, quand je clique sur mon bouton d'extraction (situé dans la feuille Menu), une première fenêtre me propose de choisir entre trois conditions : OBSO, FUTUR OBSO ou *OBSO (et place celle choisie dans la case L2 de la feuille f_lo puis une deuxième fenêtre me demande de choisir le service concerné : Achats, AQ, CQ, Info, Maintenance, Logistique.....etc (et place celui choisi dans la case M2 de la feuille f_lo)
Maintenant, il faut extraire de toutes les feuilles f_pr, f_in, f_fr, f_li les colonnes voulues des lignes qui remplissent ces deux conditions et les placer les unes à la suite des autres dans la feuille "Extraction Obso".

Le service émetteur se situe dans la colonne 6 et la condition dans la colonne 20 de chaque feuille.

Voilà, ça te donne plus d'infos sur ma façon d'exécuter la macro.




 
Vous devez vous inscrire ou vous connecter pour répondre ici.
Derniers messages publiés
Statistiques globales
Discussions
730 098
Messages
6 717 101
Membres
1 586 287
Dernier membre
lucilleguffey
Partager cette page
Haut