Fonction vba
Résolu/Fermé
katiaboutamdja
Messages postés
13
Date d'inscription
jeudi 11 novembre 2010
Statut
Membre
Dernière intervention
15 décembre 2010
-
Modifié par katiaboutamdja le 22/11/2010 à 22:29
doudou - 12 nov. 2010 à 18:16
doudou - 12 nov. 2010 à 18:16
A voir également:
- Fonction vba
- Fonction si et - Guide
- Fonction moyenne excel - Guide
- Fonction somme excel - Guide
- Erreur 1004 vba ✓ - Forum VB / VBA
- Fonction filtre excel n'existe pas - Forum Excel
2 réponses
cousinhub29
Messages postés
887
Date d'inscription
mardi 10 août 2010
Statut
Membre
Dernière intervention
14 mai 2024
328
11 nov. 2010 à 17:17
11 nov. 2010 à 17:17
Bonjour,
Afin de répondre au mieux, je pense qu'un fichier exemple, exempt de toutes données confidentielles, mais avec la structure exacte du fichier, est nécessaire...
Il suffit de remplacer les noms des sociétés, par exemple...(ainsi que les chiffres...)
Pour joindre le fichier, tu peux utiliser :
Afin de répondre au mieux, je pense qu'un fichier exemple, exempt de toutes données confidentielles, mais avec la structure exacte du fichier, est nécessaire...
Il suffit de remplacer les noms des sociétés, par exemple...(ainsi que les chiffres...)
Pour joindre le fichier, tu peux utiliser :
http://www.cijoint.fr/</code>
@ te relire
Sub dispatch()
Dim Cel As Range
Dim DerLig As Long
Dim Services As Object
Dim Sh As Worksheet
Dim It
t = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Sh In Sheets 'pour chaque feuille
If Sh.Name <> "data" Then Sh.Delete
Next Sh 'à la suivant
Application.DisplayAlerts = True
Set Services = CreateObject("Scripting.Dictionary")
With Sheets("data")
DerLig = .[H65000].End(xlUp).Row
For Each Cel In .Range("H20:H" & DerLig)
If Cel <> "" Then Services(Cel.Value) = Cel.Value
Next Cel
For Each It In Services.Items
Sheets("data").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = It
Range("H19").AutoFilter Field:=8, Criteria1:="<>" & It
Range("_FilterDataBase").Offset(1, 0).Resize(Range("_FilterDataBase"). _
Rows.Count - 1).SpecialCells(xlCellTypeVisible).ClearContents
Range("H19").AutoFilter
ActiveSheet.Shapes("Rectangle 1").Delete
Next It
.Select
End With
MsgBox Timer - t
End Sub
Voila la solution si quelqu'un en a besoin
à savoir on utilise clearcontents pour effacer le contenu des cellules
j'éspère qu'un maximum de personnes en profitera
Dim Cel As Range
Dim DerLig As Long
Dim Services As Object
Dim Sh As Worksheet
Dim It
t = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Sh In Sheets 'pour chaque feuille
If Sh.Name <> "data" Then Sh.Delete
Next Sh 'à la suivant
Application.DisplayAlerts = True
Set Services = CreateObject("Scripting.Dictionary")
With Sheets("data")
DerLig = .[H65000].End(xlUp).Row
For Each Cel In .Range("H20:H" & DerLig)
If Cel <> "" Then Services(Cel.Value) = Cel.Value
Next Cel
For Each It In Services.Items
Sheets("data").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = It
Range("H19").AutoFilter Field:=8, Criteria1:="<>" & It
Range("_FilterDataBase").Offset(1, 0).Resize(Range("_FilterDataBase"). _
Rows.Count - 1).SpecialCells(xlCellTypeVisible).ClearContents
Range("H19").AutoFilter
ActiveSheet.Shapes("Rectangle 1").Delete
Next It
.Select
End With
MsgBox Timer - t
End Sub
Voila la solution si quelqu'un en a besoin
à savoir on utilise clearcontents pour effacer le contenu des cellules
j'éspère qu'un maximum de personnes en profitera
