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.
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
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
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