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
- Vba attendre 1 seconde ✓ - Forum VB / VBA
- Fonction somme excel - Guide
- Excel compter cellule couleur sans vba - Guide
2 réponses
cousinhub29
Messages postés
993
Date d'inscription
mardi 10 août 2010
Statut
Membre
Dernière intervention
22 janvier 2025
353
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
