Macro rangement de valeur :(

Version imprimable

24/01/2016, 19h37
goul2015

3 pièce(s) jointe(s)

Macro rangement de valeur :(

Bonjour à tous,

Je suis un peu perdu , j'essaye de fabriquer une macro excel qui permettrai de ranger différemment & clairement un tableau de prime pour mes équipes.

je n'arrive pas à trouver de solution avec des boucles & copier coller .

En gros mon tableau actuel de 3 colonnes que me sort un logiciel maison :

Pièce jointe 198961

J'ai en plus comme difficulté , le fait que suivant les jours , j'ai des équipes en plus ou en moins ....

Et je souhaite faire un tableau de ce style :

Pièce jointe 198959

Merci pour votre aide pour des pistes de boucle, de code, qui pourrait m'aider à comprendre et fabriquer cette macro magique ..... cela m’éviterai de tuer des arbres en impression inutiles

Bonne soirée à tous !!
25/01/2016, 01h28
geogeo70

1 pièce(s) jointe(s)

bonsoir

pas besoin de faire des macros on obtient facilement le résultat par un tableau croisé dynamique (TCD)

voila mon essai :
Pièce jointe 198994

mettre date en colonne et equipe en ligne ; ensuite les primes en somme de valeurs

bonsoir

geogeo
25/01/2016, 22h11
goul2015

Coucou

merci GeoGeo , Effectivement le tableau croisé dynamique fonctionne bien et je vous remerci pour l'astuce
Le soucis c'est qu'il faut que je définisse à chaque fois les colonnes & autres pour chaque extraction : les étiquettes , dans quel sens va les colonnes & les lignes...
je n'arrive pas à le faire " a grande echelle " et de façon rapide. Je pensais qu'une macro aurai pu m'aider à remettre tout dans le bon sens ... mais j'arrive pas à faire des boucles ...

1 pièce(s) jointe(s)

Voila mes recherches en vba

J'ai voulu pour question de temps ne boucler qu'une fois par ligne donc faire ligne colonne et prime en une seule fois!
Ca demande de bien définir les indices...

Enfin ça fonctionne!

A vous de vous y mettre...

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
Sub tcd_vba()
 
Dim c As Integer, i As Integer, j As Integer
Dim deja As Boolean
 
 c = 7
 For i = 2 To Range("A1000").End(xlUp).Row 'lecture des lignes
  If Cells(1, c - 1) <> Cells(i, 1) Then
         Cells(1, c) = Cells(i, 1)                     ' choix de date si non doublon
         c = c + 1
  End If
  Cells(2, 6) = Cells(2, 2)                           ' Premier élément equipe
  deja = False
  fin = Range("F1000").End(xlUp).Row
  j = 2
        While Not deja And j <= fin                ' recherche doublon equipe
           deja = Cells(j, 6) = Cells(i, 2)
           j = j + 1
        Wend
        If Not deja Then
            Cells(fin + 1, 6) = Cells(i, 2)          'nouvelle equipe
            Cells(j, c - 1) = Cells(j, c - 1) + Cells(i, 3)                'prime  '
                    Else
            Cells(j - 1, c - 1) = Cells(j - 1, c - 1) + Cells(i, 3)       'prime en plus      '
        End If
 Next i
End Sub

Voici une copie d'écran :
Pièce jointe 199089

bon courage

geogeo

26/01/2016, 09h19
Marc-L

Bonjour, bonjour !

geogeo, c'est dommage de ne pas utiliser les fonctions de formules de calculs d'Excel même en VBA !

goul2015 : joindre un classeur exemple enregistré en .xlsx (donc sans macro), je posterai une p'tite démo …

______________________________________________________________________________________________________
Je suis Paris, Charlie, …
26/01/2016, 09h29
geogeo70

hello,

Bien sûr mais la demande était de se retrouver dans les "boucles", on peut même éviter le VBA.
bonne journée à tous
geogeo

______________________________________________________________________________________________________
Je suis "aussi" Paris, Charlie, …
26/01/2016, 09h41
Marc-L

T'as mal lu ‼ Et pas besoin de citer le message précédent …
Il ne s'agit pas de supprimer les boucles, juste d'utiliser en VBA l'existant d'Excel
au lieu de sa mini usine à gaz réinventant la roue au risque qu'elle fusse carrée !
Et si je demande un classeur sans macro c'est que je ne charge pas ceux avec …
26/01/2016, 23h14
goul2015

1 pièce(s) jointe(s)

Hello,

Désolé, j'avais pas vu vos réponses ( ça n'a pas marché le suivi par mail )

Ne vous engueulez pas pour moi :D

Geogeo , j'ai vu ton code & les commentaires mais wahouu en faite , ça va loin et j'ai pas tout compris malgré tes commentaires .
j'ai fait une modif pour changer la lettre des colonnes mais bref ca marche pas trop :(

Marc-L , je te joint un fichier excel type Pièce jointe 199170

Merci pour votre aide collègiale

Création des listes sans doublon des dates et des équipes via des filtres avancés puis tri des équipes :
une fois le cadre posé, dans une boucle parcourant les lignes de données,
utilisation de la fonction de feuilles de calculs d'Excel EQUIV (Match en VBA) afin de positionner les primes :

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
Sub Demo()
        Dim Rg As Range
        Application.ScreenUpdating = False
    If Worksheets.Count = 1 Then Worksheets.Add , Feuil1 Else Worksheets(2).Activate: [C3].CurrentRegion.Clear
    With Feuil1.[C3].CurrentRegion.Rows
        With .Columns(1):  .AdvancedFilter xlFilterInPlace, , , True:  .Copy:  End With
        With [C3]:  .PasteSpecial , , , True:  .Clear:  End With
        Cells(1).Select
        .Parent.ShowAllData
        .Columns(2).AdvancedFilter xlFilterCopy, , [C3], True
        Set Rg = [C3].CurrentRegion
            Rg.Columns(1).Sort Rg, Header:=True
            Rg.Rows(1).HorizontalAlignment = xlCenter
            Rg.Offset(1).NumberFormat = "* #,##0_W"
        For L& = 2 To .Count
            With .Item(L)
                C& = Application.Match(.Cells(1), Rg.Rows(1), 0)
                R& = Application.Match(.Cells(2), Rg.Columns(1), 0)
                Rg(R, C).Value = .Cells(3).Value
            End With
        Next
    End With
        Set Rg = Nothing
        Application.ScreenUpdating = True
End Sub

Rappel de l'usage du forum :
______________________________________________________________________________________________________

Merci de cliquer sur :plusser: pour chaque message ayant aidé puis sur :resolu: pour clore cette discussion …

1 pièce(s) jointe(s)

une version plus finie...

hello,

J'ai amélioré mon fichier que l'on peut utiliser en ne changeant que l'emplacement gauche de la base et l'emplacement gauche du TCD,
et depuis ton autre fichier il fallait ranger les équipes.

Donc dans ce code il suffit de remplacer "C4" et "G4" dans le code si nécessaire :

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
Sub tcd_vba()
 
Dim c As Integer, i As Integer, j As Integer
Dim deja As Boolean
Dim dercol As Integer, li As Integer, fin As Integer
 
Dim source As Range
Dim dest As Range, dest2 As Range
 
 Set source = Range("C4")   'angle à gauche de la base de données
 Set dest = Range("G4")     'angle à gauche du TCD
 
 col = source.Column
 
 c = dest.Column + 1
 li = dest.Row
 
 For i = li To source.Offset(1000, 1).End(xlUp).Row 'lecture des lignes
  If Cells(li, c - 1) <> Cells(i, col) Then
         Cells(li, c) = Cells(i, col)                     ' choix de date si non doublon
         c = c + 1
  End If
  dercol = c
  dest.Offset(1, 0) = source.Offset(0, 1)                        ' Premier élément equipe
  deja = False
  fin = dest.Offset(1000, 0).End(xlUp).Row
  j = li + 1
        While Not deja And j <= fin                ' recherche doublon equipe
           deja = Cells(j, dest.Column) = Cells(i, col + 1)
           j = j + 1
        Wend
        If Not deja Then
            Cells(fin + 1, dest.Column) = Cells(i, col + 1)        'nouvelle equipe
            Cells(j, c - 1) = Cells(j, c - 1) + Cells(i, col + 2)         'prime  '
            fin = fin + 1
                    Else
            Cells(j - 1, c - 1) = Cells(j - 1, c - 1) + Cells(i, col + 2)     'prime en plus      '
        End If
 Next i
 
 Set dest2 = dest.Offset(1, 0).Resize(fin - dest.Row, dercol - dest.Column)  'zone de tri des équipes
 Feuil1.Sort.SortFields.Clear
 dest2.Sort Key1:=dest, Order1:=xlAscending, Header:=xlGuess 'tri des équipes
 
End Sub

Le résultat semble assez rapide tout dépend de la longueur du fichier à traiter.
Pièce jointe 199299

geogeo

28/01/2016, 00h38
goul2015

wahhouuuuu RESPECT

C'est exactement ce que je cherchais ... par contre maintenant faut que je trouve comment tu as fait et quel element tu as pris pour que je comprenne comment tu as fait cela .
J'aime pas ne pas comprendre .

Mille merci vraiment beaucoup beaucoup
28/01/2016, 00h42
goul2015

Merci Géogéo , faut que je regarde aussi ce que tu as fait ...ca l'air pas mal sur le coté aussi et merci pour les annotations...ca me permettra de comprendre .

je faire ca demain soir à tête reposée

ENCORE MERCI

Merci

J'ai fait quelques modifs (en rêvant cette nuit...) j'ai calculé des "fins" en trop d'itérations j'avais déjà la valeur, je te joins un code un peu plus commenté :

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
Sub tcd_vba()
 
Dim c As Integer, i As Integer, j As Integer
Dim deja As Boolean
Dim dercol As Integer, li As Integer, fin As Integer
 
Dim source As Range
Dim dest As Range, dest2 As Range
 
 Set source = Range("C4")   'angle à gauche de la base de données
 Set dest = Range("G4")     'angle à gauche du TCD
 
 'Premier élément
 col = source.Column  'colonne source date
 c = dest.Column + 1  'colonne courante fin TCD date
 li = dest.Row        'Ligne TCD date
 fin = li + 1         'Ligne courante fin TCD
 
 For i = source.Row To source.Offset(1000, 1).End(xlUp).Row 'lecture des lignes
  If Cells(li, c - 1) <> Cells(i, col) Then
         Cells(li, c) = Cells(i, col)                     ' choix de date si non doublon
         c = c + 1
  End If
 
  deja = False
  j = li + 1
        While Not deja And j <= fin                ' recherche doublon equipe
           deja = Cells(j, dest.Column) = Cells(i, col + 1)
           j = j + 1
        Wend
        If Not deja Then
            Cells(fin + 1, dest.Column) = Cells(i, col + 1)        'nouvelle equipe
            Cells(j, c - 1) = Cells(j, c - 1) + Cells(i, col + 2)         'prime  '
            fin = fin + 1
                    Else
            Cells(j - 1, c - 1) = Cells(j - 1, c - 1) + Cells(i, col + 2)     'prime en plus      '
        End If
 Next i
 
 Set dest2 = dest.Offset(1, 0).Resize(fin - dest.Row, c - dest.Column)  'zone de tri des équipes
 Feuil1.Sort.SortFields.Clear
 dest2.Sort Key1:=dest, Order1:=xlAscending, Header:=xlGuess 'tri des équipes
 
End Sub

En espérant avoir répondu,

Bonne journée

geogeo

28/01/2016, 14h52
Marc-L

Citation:

Envoyé par goul2015

par contre maintenant faut que je trouve comment tu as fait
et quel element tu as pris pour que je comprenne comment tu as fait cela .

J'ai commencé par le B-A-BA d'Excel : un filtre avancé, un Copier puis un Coller avec transposition,
une copie directe via un second filtre avancé puis un tri : tout ceci peut être effectué manuellement
depuis la feuille de calculs et, en ayant activé au préalable l'Enregistreur de macros,
une base de code est livrée sur un plateau ! Voilà, tout est dans l'aide VBA sauf pour Match,
là il faut consulter l'aide d'Excel concernant la fonction de feuille de calculs EQUIV …

Utiliser les fonctionnalités d'Excel simplifie le code et évite les usines à gaz …

______________________________________________________________________________________________________
Pour apprendre quelque chose aux gens, il faut mélanger ce qu’ils connaissent avec ce qu’ils ignorent. (Pablo Picasso)

Bonsoir à tous, :)

Une autre façon de procéder :

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
Option Explicit
 
Sub test()
Dim a, b(), i As Long, j As Long
Dim AL As Object
    Set AL = CreateObject("System.Collections.ArrayList")
    a = Range("c3").CurrentRegion.Value
    With CreateObject("System.Collections.SortedList")
        For i = 2 To UBound(a, 1)
            If Not AL.Contains(a(i, 1)) Then AL.Add a(i, 1)
            If Not .Contains(a(i, 2)) Then
                Set .Item(a(i, 2)) = _
                CreateObject("System.Collections.SortedList")
            End If
            .Item(a(i, 2))(a(i, 1)) = .Item(a(i, 2))(a(i, 1)) + a(i, 3)
        Next
        AL.Sort
        ReDim b(1 To .Count + 1, 1 To AL.Count + 1)
        b(1, 1) = "Equipe n°"
        For i = 0 To .Count - 1
            b(i + 2, 1) = .GetKey(i)
            For j = 0 To .GetByIndex(i).Count - 1
                b(i + 2, AL.IndexOf(.GetByIndex(i).GetKey(j), 0) + 2) = _
                .GetByIndex(i).GetByIndex(j)
            Next
        Next
        For i = 0 To AL.Count - 1
            b(1, i + 2) = AL(i)
        Next
    End With
    With Range("h3").Resize(UBound(b, 1), UBound(b, 2))
        .CurrentRegion.Clear
        .Value = b
        .Borders.Weight = xlThin
        .Columns(1).Offset(, 1).Resize(1, .Columns.Count - 1).Interior.ColorIndex = 43
        .Rows(1).Offset(1).Resize(.Rows.Count - 1, 1).Interior.ColorIndex = 19
        .Columns.AutoFit
    End With
    Set AL = Nothing
End Sub

klin89

31/01/2016, 18h43
goul2015

J'ai essayé ta nouvelle methode Géogéo ca marche nikel effectivement !

Merci à vous 3 pour vos conseils et code & explication car c 'est important pour pouvoir y arriver tout seul :)