Mettre un compteur dans un compteur VBA

**awa123** · 02/12/2012, 15h37

Bonjour,

J'ai un fichier excel ("donnees") qui contient des données de base dans lequel on retrouve les différents nom de sociétés (coca cola , ice tea....) qui viennent s’installer à tel endroit ou tel endroit (Paris, Marseille....) aux années correspondantes (2012, 2013......).

Actuellement le code VBA que j'ai calcul le nombre de fois qu'il trouve le même lieu (paris....) dans ce classeur puis renvoi sa valeur au classeur "recap". (vous pouvez le consulter dans le fichier 'donnees')
Par exemple si dans le classeur "donnee" on a 'coca cola' à Paris puis à la ligne de dessous 'Ice Tea' à Paris aussi , l'algo. renverra Paris avec la valeur de 2 qui correspondra aux deux société qui sont présente à Paris.
idem pour les autres villes... Jusque là c'est parfait.

Maintenant j'aimerais rajouter l'Année qui correspond à la présence des sociétés : par exemple si 'coca cola' s'installe à Paris en 2012 , 'Ice Tea' fait pareil et 'Fanta' s'installe à Paris en 2013. J'aimerais que l'algo. prend en compte l'année c'est à dire me renvoi dans mon fichier "recap" Paris à pour valeur 2 (coca cola et Ice Tea) en 2012 et Paris a aussi la valeur de 1 (Fanta) en 2013.

Voir l’illustration du fichier 'donnees' : j'ai mis des couleurs pour bien montré qu'il y a des correspondance (même lieu au même endroit) puis j'ai rempli à la main le fichier "recap" pour vous montrer le resultat attendu.

J'ai essayé d'être le plus clair possible , si ce n'est pas le cas dites moi ce qui va pas, merci Beaucouppp

**mercatog** · 02/12/2012, 16h15

Un TCD permet de faire le nécessaire sans difficulté.
Sinon, ci-après code qui permet de synthétiser les données par site et par année et permet d'inscrire le résultat dans Feuil2 du même fichier (à adapter pour écrire le résultat -Variable Res - dans un autre fichier)

PS, il faudra activer la référence Microsoft Scripting Runtime

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
'/!\ Active la Référence Microsoft Scripting Runtime
Sub Recap()
Dim LastLig As Long, i As Long, j As Long, N As Long
Dim Dico As Scripting.Dictionary
Dim Tb, Tmp, Res()
Dim Str As String
 
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Feuil1")
    LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
    Tb = .Range("A2:D" & LastLig)
End With
 
Set Dico = New Scripting.Dictionary
For i = 1 To LastLig - 1
    Str = Tb(i, 2) & "µ" & Tb(i, 4)
    If Not Dico.Exists(Str) Then
        Dico.Add Str, CStr(i)
    Else
        Dico(Str) = Dico(Str) & ";" & CStr(i)
    End If
Next i
 
N = Dico.Count
If N > 0 Then
    ReDim Res(1 To N, 1 To 6)
    For j = 1 To N
        Tmp = Split(Dico.keys(j - 1), "µ")
        Res(j, 1) = Tmp(0)
        Res(j, 6) = Tmp(1)
        Res(j, 5) = Nb(Dico.Items(j - 1))
    Next j
    ThisWorkbook.Worksheets("Feuil2").Range("A3").Resize(N, 6) = Res
End If
Set Dico = Nothing
End Sub
 
Private Function Nb(ByVal Str As String, Optional ByVal Sep As String = ";") As Integer
 
Nb = Len(Str) - Len(Replace(Str, Sep, "")) + 1
End Function

**Daniel.C** · 02/12/2012, 18h09

Bonjour,

Une autre solution en exploitant un TCD temporaire construit puis supprimé sur Feuil2 (suppose que les deux classeurs sont ouverts). Mets la macro dans le classeur "Données" :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Test()
    Dim Plage As Range, An As PivotItem, Ville As PivotItem, T1 As ListObject
    Dim LR As ListRow
    With Sheets("Feuil1")
        Set Plage = .Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 4)
    End With
    With Sheets("Feuil2")
    If .PivotTables.Count > 0 Then .PivotTables(1).TableRange2.Clear
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Feuil1!" & Plage.Address(, , xlR1C1), Version:=xlPivotTableVersion14).CreatePivotTable _
        TableDestination:="Feuil2!R3C1", TableName:="TCD", _
        DefaultVersion:=xlPivotTableVersion14
        With .PivotTables("TCD").PivotFields("lieu d'Usines")
            .Orientation = xlRowField
            .Position = 1
        End With
        With .PivotTables("TCD").PivotFields("Annee")
            .Orientation = xlColumnField
            .Position = 1
        End With
        .PivotTables("TCD").AddDataField .PivotTables("TCD").PivotFields("Société"), _
            "Nombre de Société", xlCount
        Set T1 = Workbooks("awa123 recap.xlsx").Sheets("Feuil1").ListObjects(1)
        For i = T1.ListRows.Count To 1 Step -1
            T1.ListRows(i).Delete
        Next i
        With .PivotTables("TCD")
            For Each An In .PivotFields("Annee").PivotItems
                For Each Ville In .PivotFields("lieu d'Usines").PivotItems
                   If An = "(blank)" Then
                        Var = .GetPivotData("Société", "lieu d'Usines", Ville, "Annee", "(vide)")
                   Else
                        Var = .GetPivotData("Société", "lieu d'Usines", Ville, "Annee", An)
                   End If
                   If Var <> "" Then
                        Set LR = T1.ListRows.Add(, alwaysinsert:=True)
                        LR.Range(1, 1) = Ville
                        LR.Range(1, 6) = An
                        LR.Range(1, 5) = Var
                   End If
                Next Ville
            Next An
        End With
        .PivotTables(1).TableRange2.Clear
    End With
 
End Sub

**awa123** · 02/12/2012, 19h59

Merci !

Mercatog peut tu me dire stp ce qu'il faut rajouter dans ton code pour que les resultats arrivent dans le fichier "recap" à la 'Feuil1' ???

j'ai essayé de faire des manip. mais c'est sans resultats , il y a toujours des erreurs.
merci beaucoup

**mercatog** · 02/12/2012, 21h41

Quel est le code avec lequel tu ouvre le fichier Recap?
Il suffit de changer la ligne 34 du code.

**awa123** · 02/12/2012, 21h43

j'utilise ce code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
'/!\ Active la Référence Microsoft Scripting Runtime
Sub Recap()
Dim LastLig As Long, i As Long, j As Long, N As Long
Dim Dico As Scripting.Dictionary
Dim Tb, Tmp, Res()
Dim Str As String
 
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Feuil1")
    LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
    Tb = .Range("A2:D" & LastLig)
End With
 
Set Dico = New Scripting.Dictionary
For i = 1 To LastLig - 1
    Str = Tb(i, 2) & "µ" & Tb(i, 4)
    If Not Dico.Exists(Str) Then
        Dico.Add Str, CStr(i)
    Else
        Dico(Str) = Dico(Str) & ";" & CStr(i)
    End If
Next i
 
N = Dico.Count
If N > 0 Then
    ReDim Res(1 To N, 1 To 6)
    For j = 1 To N
        Tmp = Split(Dico.keys(j - 1), "µ")
        Res(j, 1) = Tmp(0)
        Res(j, 6) = Tmp(1)
        Res(j, 5) = Nb(Dico.Items(j - 1))
    Next j
    ThisWorkbook.Worksheets("Feuil2").Range("A3").Resize(N, 6) = Res
End If
Set Dico = Nothing
End Sub
 
Private Function Nb(ByVal Str As String, Optional ByVal Sep As String = ";") As Integer
 
Nb = Len(Str) - Len(Replace(Str, Sep, "")) + 1
End Function

d'acord il faut changer la ligne 34 mais que mettre à la place pour que ça transfert bien les resultat dedans?

merci énormement

Mettre un compteur dans un compteur VBA

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager