Moyennes en fonction des dates

Version imprimable

Bonjour à tous, et tout d'abord tous mes voeux pour 2013!

Deux petites questions qui peuvent être stupides ce dont je m'excuse mais je débute en VBA:

QUESTION 1. J'ai un fichier Excel disons avec une colonne B de dates (plusieurs dates peuvent etre identiques), une colonne C de chiffres (rendements).

Il me faudrait creer un autre worksheet ayant la forme suivante (une ligne par date, unique cette fois):

en colonne A: Date
en colonne B: plus petite valeur de C pour cette date
en colonne C: moyenne des rendements pour cette date

QUESTION 2. j'avais des fichiers excel de 700 à 900.000 lignes à traiter dans lesquels il faut juste enlever les lignes qui contiennent un "#N/A". J’avais commencé avec des Offset et autre Delete mais cela prenait des heures. Ensuite j'ai essayé d’optimiser le code et cela prends une vingtaine de minutes pour cette macro, mais je suis sur que l'on peut faire bien mieux. Avez-vous des suggestions?

Voice le code actuel:
Code:

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 Public Sub H_DeleteNA() 'To delete all 'bad' cells as #N/A we got in column C and D Dim fSourceH As Worksheet Dim fDestH As Worksheet Dim i As Long Dim idest As Long Dim ifin As Long Set fSourceH = Worksheets("Feuil2") ' définit la feuille 1 en feuille source Set fDestH = Worksheets("Feuil1") idest = 1 Rows("1:1").Delete shift:=xlUp 'efface la premiere ligne qui est inutile ifin = fSourceH.Range("C:C").End(xlDown).Row For i = 1 To ifin If IsNumeric(fSourceH.Range("C" & i).Value) Then fSourceH.Range("A" & i & ":D" & i).Copy fDestH.Range("A" & idest) idest = idest + 1 End If Next i fSourceH.Range("A:D").ClearContents 'efface Feuil2 Set fSourceH = Worksheets("Feuil1") ' définit la feuille 1 devient ma source Set fDestH = Worksheets("Feuil2") fSourceH.Activate idest = 1 Range("A3").Activate ifin = fSourceH.Range("d1048576").End(xlUp).Row + 1 For i = 1 To ifin If IsNumeric(fSourceH.Range("D" & i).Value) Then fSourceH.Range("A" & i & ":D" & i).Copy fDestH.Range("A" & idest) idest = idest + 1 End If Next i fSourceH.Range("A:D").ClearContents 'efface Feuil1 fSourceH.Name = "FeuilTemp" fDestH.Name = "Feul1" End Sub
Merci par avance de vos précieux conseils

18/01/2013, 18h50
GerardCalc

Bonsoir,

Question 1 : Utilises le tableau croisé dynamique.
Question 2 : Le VBA est hors de mon champ de compétence.

A+
18/01/2013, 20h03
fastmike

Merci de ta réponse! Malheureusement je dois le coder en VBA et de toute facon les pivot table deviennent trop lent sur les gros fichiers.

Merci encore :lol:

Bonjour,
Pour la deuxième question, voici une solution.
Il y a sans doute mieux mais je n'ai pas eu le temps d'approfondir la question.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 Sub DelRowsError() Dim sht As Worksheet Dim Rng As Range, myTable() As String, r As Long, lastRow As Long Set sht = ActiveSheet Set Rng = sht.Range("A1").CurrentRegion With Rng Set Rng = .SpecialCells(xlCellTypeFormulas, xlErrors) End With myTable = Split(Rng.Address, ",") With sht For r = UBound(myTable) To 0 Step -1 If lastRow <> .Range(myTable(r)).Row Then lastRow = .Range(myTable(r)).Row: Rows(lastRow).Delete End If Next End With Set Rng = Nothing End Sub
[EDIT]
Le code que j'ai donné est pour des messages d'erreurs sur des cellules se trouvant dans des colonnes différentes mais il peut-être plus simple si la recherche se fait sur une colonne particulière
Code:

1 2 3 4 5 Sub test() On Error Resume Next Columns("H").SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete On Error GoTo 0 End Sub

18/01/2013, 21h08
fastmike

Bonsoir Philippe

Trop fort! Ceci devrait sans doute résoudre ma deuxième question. Je vais tester dès maintenant.

J'aimerai atteindre un jour cette rapidité à encoder!!!

Merci mille fois

Je viens de tester cela et je retombe un peu sur ma problématique initiale qui m'avait conduit à copier les lignes à conserver vers un autre worksheet.

En effet, si j'utilise les .Delete de Excel, cela semble bien fonctionner pour les fichiers de moins de 50 000 lignes, et ensuite cela devient d'une lenteur effroyable. En copiant les données à conserver vers une autre feuille au lieu d'effacer les lignes dans la feuille en cours, j'ai gagné énormément de temps (de plus de 6h à moins de 20 minutes pour un fichier de 900 000 lignes).

Curieusement, il semble que les fonctions delete (ou insertion) sur la feuille en cours, gèrent assez mal la mémoire, mais je n'y connais pas grand chose je l'avoue. Je continue donc de creuser.

Merci encore pour vos idées et de me permettre de bénéficier de votre connaissance.
18/01/2013, 22h27
Philippe Tulliez
Bonjour,
J'avoue ne pas avoir poussé le test jusqu'à ce nombre de lignes imposant.
Il y a sans doute d'autres moyens d'accélérer la vitesse.
Stopper la mise à jour de l'écran et couper le calcul automatique puisque j'ai cru comprendre qu'il y a des formules dans cette feuille.
Code:

1 2 Application.screenUpdating = False Application.Calculation = xlCalculationManual
et en fin de procédure remettre le calcul automatique et le ScreenUpdating à True (Pas obligatoire pour ce dernier mais préférable.
18/01/2013, 22h38
NVCfrm
Bonsoir.
Une piste:

j'ai cru comprendre que tu cherches à purifier une plage excluant les lignes où la colonne c contiendrait une valeur d'erreur.
J'ai noté que la première ligne est inutile.
Je proposes de copier la feuille
Code:

1 2 3 dim Cible as range,rx as range Sheets("Probleme").Copy Sheets.Count Sheets("Probleme").UsedRange.Clear
Créer la valeur d'erreur dans la première ligne de la colonne 3
Code:

1 2 Set rx = Sheets(Sheets.count).Range("C1") rx.Formula="=MATCH(""wwy"",RC[1]:RC[3],0)"
Demander à Excel un objet range qui exclue toutes les cellules qui contiennent cette valeur

Code:

Set cible = Sheets(Sheets.count).Range("a1").CurrentRegion.Columns(3).ColumnDifferences(rx)

il te faut 5 variables numérique de type Long
Code:

1 2 3 4 5 6 7 Dim Area_Compte as long, Area_Lignes as Long, Dest_Ligne as Long, n as long, i as Long Do n=n+1 Loop Until n = areas_Compte
Tout se déroule dans une seule boucle. Les propriétés range nous éviteront un codage fastidieux de boucles.

Cette boucle ci-dessus balaie les Areas renvoyés par cible.
l'idée serait de faire une déduction dans cette boucle pour renvoyer la plage correspondante aux coordonnée de l'areas(n) sans passer par un balayage ligne par ligne.
Il faut savoir bien poser tes crans pour la destination:

Code:

Dest_Ligne = Sheets("Probleme").Range("a1").CurrentRegion.Rows.count

te renverra toujours la dernière ligne de données à incrémenter d'un pas.

Code:

Area_Lignes = Cible.Areas(n).Rows.Count

tu obtiens le nombre de lignes de l'areas en cours.
Area_Lignes et Dest_Ligne te suffisent pour déterminer la nouvelle plage de destination.

pour t'orienter un peu plus

Code:

Sheets("Probleme").Range(cells(dest_ligne + 1,1),cells(dest_ligne + area_lignes+1,nombre_colonnes)).value=cible.areas(n).value

N'oublie pas qu'avant d'entrer dans la boucle, il te faut activer la feuille Problème

Code:

sheets("probleme").activate

n'oublie pas qu'il est essentiel de désactiver le rafraîchissement d'écran et éventuellement mettre le mode de calcul à manuel en début de procédure,
en fin de procédure, remettre le rafraîchissement d'écran en place après avoir supprimé la copie crée.

Code:

Sheets(Sheets.count).Delete

Code:

Application.ScreenUpdating=True

je penses t'avoir fourni suffisamment d'indications pour aborder ton problème.

Bon code!:P

Les explications ci-haut sont incomplètes.

En fait il s'agit d'obtenir la plage purifiée et non la colonne.

Il faut référencer directement la plage avec le nom de colonne n°1 et le nom de colonne en dernier:

Code:

Sheets("Probleme").Range.....Value = Sheets(Sheets.count).Range("A" & Cible.Areas(n).Row & ":C" & Cible.Areas(n).Row + Area_Lignes).Value

Autre chose:

Code:

Application.InterActive=False

Vu la longueur du temps, interdire les manipulations Clavier/Souris durant l'opération éviterait l'inattendu.
Ne pas oublier de le remettre à True à la fin.
19/01/2013, 09h52
fastmike

Mille fois merci!!!

Alors la, chapeau!

Je ne m'attendais pas à recevoir des réponses aussi détaillées et si rapidement!

Vous êtes géniaux tout simplement :ccool:

Voici un problème de réglé.

Je planche maintenant sur la question 1 sur laquelle j'ai fait quelques progrès mais avec un code 'sale' du fait de ma méconnaissance des fonctions VBA..

Bonne journée à tous.

Solution non optimisée pour la question 1

Bonjour

Pour info, voici une version qui fonctionne mais peut sans aucun doute être optimisée faute de connaissance des fonctions disponibles. Elle tourne en environ 9 minutes pour un fichier de 700 000 lignes.
:ccool:

Code:

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
103
104
105
106
107
108
109
110
111
112
113
114
 
 
'_________________________________________________
 
 
Public Sub Portfolios()
 
Dim fSource As Worksheet
Dim fDest As Worksheet
Dim pf1, pf2, pf3, pf4, pf5, pf6 As Worksheet
 
Dim sdeb As Long
Dim sfin As Long
Dim ddeb As Long
Dim dfin As Long
Dim iPF1, iPF2, iPF3, iPF4, iPF5, iPF6 As Long
Dim CapMarket As Long
 
Dim i, j, k, nb As Long
 
Dim wf As WorksheetFunction: Set wf = WorksheetFunction
Dim MinCap, MaxCap, MoyRend As Double
Dim MinCol As Long
Dim MinHead As String
 
 
ideb = 1
ifin = 1
iPF1 = 1
iPF2 = 1
iPF3 = 1
iPF4 = 1
iPF5 = 1
iPF6 = 1
 
'(After:=Worksheets(Worksheets.Count)).Name = "PF1"
 
If IsError(Evaluate("='" & "PF1" & "'!A1")) Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "PF1"
If IsError(Evaluate("='" & "PF2" & "'!A1")) Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "PF2"
If IsError(Evaluate("='" & "PF3" & "'!A1")) Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "PF3"
If IsError(Evaluate("='" & "PF4" & "'!A1")) Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "PF4"
If IsError(Evaluate("='" & "PF5" & "'!A1")) Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "PF5"
If IsError(Evaluate("='" & "PF6" & "'!A1")) Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "PF6"
 
Set fSource = Worksheets("Feul1") ' définit la feuille 1 en feuille source
fSource.Activate
ifin = fSource.Range("C:C").End(xlDown).Row
 
For i = 1 To ifin
 CapMarket = fSource.Range("C" & i).Value
 If IsEmpty(fSource.Range("E" & i).Value) = False Then
  Select Case CapMarket
    Case Is >= 2000
         fSource.Range("A" & i & ":E" & i).Copy Worksheets("PF6").Range("A" & iPF6)
         iPF6 = iPF6 + 1
    Case Is >= 500
         fSource.Range("A" & i & ":E" & i).Copy Worksheets("PF5").Range("A" & iPF5)
         iPF5 = iPF5 + 1
    Case Is >= 250
         fSource.Range("A" & i & ":E" & i).Copy Worksheets("PF4").Range("A" & iPF4)
         iPF4 = iPF4 + 1
    Case Is >= 50
         fSource.Range("A" & i & ":E" & i).Copy Worksheets("PF3").Range("A" & iPF3)
         iPF3 = iPF3 + 1
    Case Is >= 25
         fSource.Range("A" & i & ":E" & i).Copy Worksheets("PF2").Range("A" & iPF2)
         iPF2 = iPF2 + 1
    Case Else
         fSource.Range("A" & i & ":E" & i).Copy Worksheets("PF1").Range("A" & iPF1)
         iPF1 = iPF1 + 1
 
  End Select
 End If
 Next i
 
 For i = 1 To 6              'tri sur la colonne date
 
    Worksheets("PF" & i).Activate
    Columns("A:E").Select
    Selection.Sort Key1:=Range("B1")
    k = 1
    Range("K" & k) = "Date"
    Range("L" & k) = "Min"
    Range("M" & k) = "Rendement"
    Range("N" & k) = "Moyenne Rdt"
    Range("O" & k) = "Max"
    Range("P" & k) = "Rendement"
    k = k + 1
    ifin = Range("C:C").End(xlDown).Row
    j = 1
    While j < ifin - 1
 
      nb = 1
       While Range("B" & (j + nb)) = Range("B" & j)
       nb = nb + 1
       Wend
       MinCap = wf.Min(Range("C" & j & ":C" & (j + nb - 1)))
       MaxCap = wf.Max(Range("C" & j & ":C" & (j + nb - 1)))
       MoyRend = wf.Average(Range("E" & j & ":E" & (j + nb - 1)))
       Range("J" & k).Value = "PortFolio" & i
       Range("K" & k).Value = Range("B" & j).Value 'je copie ma date
       Range("L" & k).Value = MinCap   'je copie la valeur mini pour cette date
       Range("M" & k).Value = Range("E" & (wf.Match(MinCap, Range("C" & j & ":C" & (j + nb - 1)), 0)) + j - 1) 'je copie le rendement correspondant
       Range("N" & k).Value = MoyRend   'je copie la valeur moyenne des rendements pour cette date
       Range("O" & k).Value = MaxCap   'je copie la valeur maxi pour cette date
       Range("P" & k).Value = Range("E" & (wf.Match(MaxCap, Range("C" & j & ":C" & (j + nb - 1)), 0)) + j - 1) 'je copie le rendement correspondant
 
   j = j + nb
   k = k + 1
 Wend
 
Next i
 
End Sub