Doodle extraction Excel

**matlabation** · 11/07/2019, 12h13

Bonjour à tous,

J'aimerai réussir à exploiter des données Doodle, je ne sais pas si cela est réalisable...

Tous les mois on reçoit un Doodle de disponibilités des collaborateurs, on fait une extraction excel (Cf. capture écran)

J'aimerai que sur cette extraction excel, sur une deuxième feuille je réussisse à extraire sous forme de tableau uniquement les OK en vert ( avec les dates et créneaux horaires).

Merci par avance de votre aide,

Nom : Doodle.png
Affichages : 2034
Taille : 45,4 Ko

Nom : Doodle.png
Affichages : 2034
Taille : 45,4 Ko

**Menhir** · 11/07/2019, 12h20

Je ne comprends pas bien ta demande.

Tu voudrais un tableau avec deux colonnes (Personne et Date) et avec une ligne pour chaque Ok de ce tableau.
C'est ça ?

**matlabation** · 11/07/2019, 14h24

Je veux un tableau selon la date et les créneau ( matin/ après-midi) ou seul les personnes apparaissent:

Par exemple pour lundi 1 juillet sur le créneau 9h00-15h15 je veux voir apparaître: personne 1, 5,6,7,8,10,11,...

**ARTURO83** · 12/07/2019, 09h53

Bonjour

le fichier en exemple
Pièce jointe 490637

le 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
43
44
45
46
47
48
Option Compare Text
 
Sub Repartition()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig_f1 As Long, DerCol_f1 As Long, Lig As Long, i As Long, C As Long
    Dim Cell As Range
 
    Application.ScreenUpdating = False
    Set f1 = Sheets("Extract_Doodle")
    Set f2 = Sheets("Repartition")
    DerLig_f1 = f1.[A100000].End(xlUp).Row
    DerCol_f1 = f1.[XFD3].End(xlToLeft).Column
 
    'Préparation feuille "Resultats"
    f2.Cells.ClearContents 'on efface les précédents résultats
 
    'Relevé des dates de la feuille "Extract_Doodle"
    Lig = 2
    For i = 2 To DerCol_f1 Step 2
        f2.Cells(Lig, "A") = f1.Cells(2, i)
        Lig = Lig + 1
    Next i
 
    'Relevé des horaires de la feuille "Extract_Doodle"
    Set d = CreateObject("Scripting.Dictionary")
    For Each Cell In f1.Range(f1.Cells(3, "B"), f1.Cells(3, DerCol_f1))
        If Not d.exists(Cell.Value) Then d(Cell.Value) = ""
    Next Cell
    If d.Count > 0 Then f2.[B1].Resize(, d.Count) = d.keys
 
    'Relevé des personnes OK
    Lig = 2
    For C = 2 To DerCol_f1
        Horaire = f1.Cells(3, C)
        For l = 4 To DerLig_f1
            If f1.Cells(l, C) = "Ok" Then
                Set Col = f2.Rows(1).Find(Horaire, LookIn:=xlValues, lookat:=xlWhole)
                f2.Cells(Lig, Col.Column) = f2.Cells(Lig, Col.Column) & f1.Cells(l, "A") & ", "
            End If
        Next l
        If C Mod 2 = 1 Then Lig = Lig + 1
    Next C
 
    f2.Select
    Set f1 = Nothing
    Set f2 = Nothing
    Set Col = Nothing
End Sub

Cdlt

**matlabation** · 15/07/2019, 10h33

Bonjour,

Merci beaucoup pour ta réponse.

Effectivement ça extrait bien les noms des personnes dispos, mais du coup ça rends la lecture plus difficile, on est obligé de chercher le nom pour savoir si elle est dispo ou pas.

Je ne sais pas s'il est possible de les avoir sous format de listing ou même crée un onglet par jour ou on vois apparaître les noms des personnes dispo matin et dispo soir.

Je ne sais si c'est faisable.

Milles mercis à vous!

Toujours au top!

**ARTURO83** · 15/07/2019, 11h27

Bonjour,

Autre présentation sous forme de listing

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
48
49
50
51
Sub Repartition_Listing()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig_f1 As Long, DerCol_f1 As Long, Lig As Long, i As Long, C As Long
    Dim Cell As Range
 
    Application.ScreenUpdating = False
    Set f1 = Sheets("Extract_Doodle")
    Set f2 = Sheets("Listing")
    DerLig_f1 = f1.[A100000].End(xlUp).Row
    DerCol_f1 = f1.[XFD3].End(xlToLeft).Column
 
    'Préparation feuille "Resultats"
    f2.Cells.ClearContents 'on efface les précédents résultats
 
    'Relevé des dates de la feuille "Extract_Doodle"
    ReDim Pers(DerLig_f1, DerCol_f1) As String
    ReDim Jour(DerLig_f1, DerCol_f1) As String
    ReDim Horaire(DerLig_f1, DerCol_f1) As String
    ReDim V_OK(DerLig_f1, DerCol_f1) As String
    Nb_Cell = 1
    For i = 4 To DerLig_f1
        For J = 2 To DerCol_f1
            If f1.Cells(i, J) = "OK" Then
                V_OK(i, J) = "OK"
                Pers(i, J) = f1.Cells(i, "A")
                If J Mod 2 = 0 Then Jour(i, J) = f1.Cells(2, J) Else Jour(i, J) = f1.Cells(2, J - 1)
                Horaire(i, J) = f1.Cells(3, J)
                'Nb_Cell = Nb_Cell + 1
            End If
        Next J
    Next i
 
    'Remplissage listing
    Lig = 2
    For i = 4 To DerLig_f1
        For J = 2 To DerCol_f1
            If V_OK(i, J) = "OK" Then
                f2.Cells(Lig, "A") = Pers(i, J)
                f2.Cells(Lig, "B") = Jour(i, J)
                f2.Cells(Lig, "C") = Horaire(i, J)
                Lig = Lig + 1
            End If
        Next J
    Next i
    f2.Range("A1:C1") = Array("Personnel", "Jour", "Horaire")
    f2.Select
 
    Set f1 = Nothing
    Set f2 = Nothing
    Set Col = Nothing
End Sub

Pièce jointe 491101

A partir de là vous pouvez utiliser les filtres par personnes, par jours ou par horaires.

Cdlt

**matlabation** · 15/07/2019, 13h13

C'est TOP!

MERCIIIIIIIIIIIIIIIIIII

**matlabation** · 15/07/2019, 14h09

Je relance cette discussion.

Après test, j'ai constaté qu'il y'avais des doublons sur le listing quand sur la journée un seul créneau horaire était proposer.

Et aussi le fait que je l'applique sur un doodle du mois ( la totalité du mois et non pas une semaine), il y a des dates qui ne sont pas prises en compte.

Est-ce normal?

**ARTURO83** · 15/07/2019, 14h26

Puis-je voir l'extraction sur le mois?

**matlabation** · 15/07/2019, 15h51

Doodle Juillet.xlsx

Le voila

**ARTURO83** · 15/07/2019, 17h38

Evidemment, l'extraction est différente de la demande initiale.
Voici avec les adaptions

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
48
49
50
51
52
53
Option Compare Text
 
Sub Repartition_Listing()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig_f1 As Long, DerCol_f1 As Long, Lig As Long, i As Long, C As Long
    Dim Cell As Range
 
    Application.ScreenUpdating = False
    Set f1 = Sheets("Sondage")
    Set f2 = Sheets("Listing")
    DerLig_f1 = f1.[A100000].End(xlUp).Row
    DerCol_f1 = f1.[XFD6].End(xlToLeft).Column
 
    'Préparation feuille "Resultats"
    f2.Cells.ClearContents 'on efface les précédents résultats
 
    'Relevé des dates de la feuille ""
    ReDim Pers(DerLig_f1, DerCol_f1) As String
    ReDim Jour(DerLig_f1, DerCol_f1) As String
    ReDim Horaire(DerLig_f1, DerCol_f1) As String
    ReDim V_OK(DerLig_f1, DerCol_f1) As String
    Nb_Cell = 1
    For i = 7 To DerLig_f1
        For J = 4 To DerCol_f1
            If f1.Cells(i, J) = "OK" Or f1.Cells(i, J) = "(OK)" Then
                V_OK(i, J) = "OK"
                Pers(i, J) = f1.Cells(i, "A")
                If J Mod 2 = 0 Then Jour(i, J) = f1.Cells(5, J) Else Jour(i, J) = f1.Cells(5, J - 1)
                Horaire(i, J) = f1.Cells(6, J)
                'Nb_Cell = Nb_Cell + 1
            End If
        Next J
    Next i
 
    'Remplissage listing
    Lig = 2
    For i = 7 To DerLig_f1
        For J = 4 To DerCol_f1
            If V_OK(i, J) = "OK" Then
                f2.Cells(Lig, "A") = Pers(i, J)
                f2.Cells(Lig, "B") = Jour(i, J)
                f2.Cells(Lig, "C") = Horaire(i, J)
                Lig = Lig + 1
            End If
        Next J
    Next i
    f2.Range("A1:C1") = Array("Personnel", "Jour", "Horaire")
    f2.Select
 
    Set f1 = Nothing
    Set f2 = Nothing
    Set Col = Nothing
End Sub