Je pense que je vais supprimer une de deux feuilles (Personnel ou Comptage) et n'en faire qu'une. Copier les prénoms venant de la feuille Planning et les mettre à la suite de l'autre dans une colonne. Je test et je vous ferai un retour.
Bonjour,Je pense que je vais supprimer une de deux feuilles (Personnel ou Comptage) et n'en faire qu'une. Copier les prénoms venant de la feuille Planning et les mettre à la suite de l'autre dans une colonne. Je test et je vous ferai un retour.
(il n'est plus là mais à laisser une bibliothèque pour nous aider). J'espère qu'il vous sera très utile.
Option Explicit
Dim d As Object
Sub RecapMachine()
Dim Fp As Worksheet, Fc As Worksheet, Tb(), dl As Integer, i As Integer, j As Integer
Dim plage As Range, C As Range
Set Fp = ThisWorkbook.Worksheets("personnel")
Set Fc = ThisWorkbook.Worksheets("feuil2") 'feuille à adapter
Set d = CreateObject("scripting.dictionary")
With Fp
dl = .Range("A" & Rows.Count).End(xlUp).Row
Tb = .Range("B2:AE" & dl).Value
End With
'on récupère tous les noms sans doublons en utilisant le dictionnaire 'd'
'pour dimensionner le Tableau Tt avec lequel on va récuperer le nombre de fois agent sur même machine
For i = LBound(Tb) To UBound(Tb)
For j = LBound(Tb, 2) To UBound(Tb, 2)
If Tb(i, j) <> "" Then d(Tb(i, j)) = ""
Next j
Next i
DicoTri d 'on tri pour avoir les noms triés
ReDim Tt(1 To d.Count - 1, 1 To 31) ' on dimensionne le tableau
'on alimente entete
For i = 2 To 31
Tt(1, i) = Fp.Cells(1, i)
Next i
' on alimente les noms
For i = 2 To d.Count - 1
Tt(i, 1) = d.keys()(i)
Next i
' on comptabilise les occurences des noms
For j = 2 To UBound(Tt, 2)
For i = 2 To UBound(Tt)
Set plage = Fp.Range(Fp.Cells(2, j), Fp.Cells(dl, j))
If Application.CountA(plage) = 0 Then
Exit For
Else
For Each C In plage
If C.Value = Tt(i, 1) Then Tt(i, j) = Tt(i, j) + 1
Next C
End If
Next i
Next j
'report sur la feuille
With Fc
.Cells.Clear
.Range("A1").Resize(UBound(Tt), UBound(Tt, 2)) = Tt
.Range("A1").CurrentRegion.Borders.Weight = xlThin
.Rows(1).Orientation = xlVertical
.Columns("A:AE").EntireColumn.AutoFit
With .Range("A1").CurrentRegion.Offset(1, 1)
.HorizontalAlignment = xlCenter
.Font.Bold = True
End With
End With
Set plage = Nothing
Set d = Nothing
Set Fc = Nothing: Set Fp = Nothing
End Sub
Sub DicoTri(dico) 'Source du code http://boisgontierj.free.fr/
Dim i As Integer, Tbl
Tbl = d.keys ' Transfert Dictionnaire dans Array
Tri Tbl, LBound(Tbl), UBound(Tbl) ' Tri Array
d.RemoveAll ' Création du dictionnaire
For i = LBound(Tbl) To UBound(Tbl)
d(Tbl(i)) = ""
Next i
End Sub
Sub Tri(a, gauc, droi) ' Quick sort 'Source du code http://boisgontierj.free.fr/
Dim ref As String, g As Integer, d As Integer, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
Do While a(g) < ref: g = g + 1: Loop
Do While ref < a(d): d = d - 1: Loop
If g <= d Then
temp = a(g): a(g) = a(d): a(d) = temp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call Tri(a, g, droi)
If gauc < d Then Call Tri(a, gauc, d)
End SubMerci pour ton soutien, mais là, je suis perdu..Bonjour,
@chinel : Tu nous as dit que tu avais une vie après le boulot. Nous aussi.
Comme vous ramez (toi et ton chef) à l'envers. J'ai trouvé un moment pour une solution. Tu trouveras dans 2 codes le lien du site de feu Jacques Boisgontier
/!\ il faut adapter le nom de la feuille qui recevra le résultat.
VB:Option Explicit Dim d As Object Sub RecapMachine() Dim Fp As Worksheet, Fc As Worksheet, Tb(), dl As Integer, i As Integer, j As Integer Dim plage As Range, C As Range Set Fp = ThisWorkbook.Worksheets("personnel") Set Fc = ThisWorkbook.Worksheets("feuil2") 'feuille à adapter Set d = CreateObject("scripting.dictionary") With Fp dl = .Range("A" & Rows.Count).End(xlUp).Row Tb = .Range("B2:AE" & dl).Value End With 'on récupère tous les noms sans doublons en utilisant le dictionnaire 'd' 'pour dimensionner le Tableau Tt avec lequel on va récuperer le nombre de fois agent sur même machine For i = LBound(Tb) To UBound(Tb) For j = LBound(Tb, 2) To UBound(Tb, 2) If Tb(i, j) <> "" Then d(Tb(i, j)) = "" Next j Next i DicoTri d 'on tri pour avoir les noms triés ReDim Tt(1 To d.Count - 1, 1 To 31) ' on dimensionne le tableau 'on alimente entete For i = 2 To 31 Tt(1, i) = Fp.Cells(1, i) Next i ' on alimente les noms For i = 2 To d.Count - 1 Tt(i, 1) = d.keys()(i) Next i ' on comptabilise les occurences des noms For j = 2 To UBound(Tt, 2) For i = 2 To UBound(Tt) Set plage = Fp.Range(Fp.Cells(2, j), Fp.Cells(dl, j)) If Application.CountA(plage) = 0 Then Exit For Else For Each C In plage If C.Value = Tt(i, 1) Then Tt(i, j) = Tt(i, j) + 1 Next C End If Next i Next j 'report sur la feuille With Fc .Cells.Clear .Range("A1").Resize(UBound(Tt), UBound(Tt, 2)) = Tt .Range("A1").CurrentRegion.Borders.Weight = xlThin .Rows(1).Orientation = xlVertical .Columns("A:AE").EntireColumn.AutoFit With .Range("A1").CurrentRegion.Offset(1, 1) .HorizontalAlignment = xlCenter .Font.Bold = True End With End With Set plage = Nothing Set d = Nothing Set Fc = Nothing: Set Fp = Nothing End Sub Sub DicoTri(dico) 'Source du code http://boisgontierj.free.fr/ Dim i As Integer, Tbl Tbl = d.keys ' Transfert Dictionnaire dans Array Tri Tbl, LBound(Tbl), UBound(Tbl) ' Tri Array d.RemoveAll ' Création du dictionnaire For i = LBound(Tbl) To UBound(Tbl) d(Tbl(i)) = "" Next i End Sub Sub Tri(a, gauc, droi) ' Quick sort 'Source du code http://boisgontierj.free.fr/ Dim ref As String, g As Integer, d As Integer, temp ref = a((gauc + droi) \ 2) g = gauc: d = droi Do Do While a(g) < ref: g = g + 1: Loop Do While ref < a(d): d = d - 1: Loop If g <= d Then temp = a(g): a(g) = a(d): a(d) = temp g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call Tri(a, g, droi) If gauc < d Then Call Tri(a, gauc, d) End Sub
j'ai ajouter une feuille "Feuil2" pour ne pas modifier ton code et dans ma feuille "Planning" j'ai ajouter un bouton qui active ta macro, mais j'ai un bug 
Sans message du bug, désolé de ne pouvoir t'en dire plus.Merci pour ton soutien, mais là, je suis perdu..
Salut TooFatBoy
, chez-moi aucun plantage avec démo à l'appui. m'a donné la solution (ICI).
: Si tu ne fais pas attention à ce que tu écris, tu vas droit au mur.) avait attiré ton attention dans ce sens.
De quoi parles tu ? Je n'ai pas compris le sens de ta phrase ?@chinel
@Phil69970 (
Ton fichier en retour
Ton fichier fonctionne bien, merci pour ton boulot ! Je ne suis pas aussi fort que toi en VBA alors certaines explications m'échappent, désolé
Je fais allusion à l'orthographe de la nouvelle feuille que tu as ajouté. Il semble que tu ajoutes des espaces partout. Est-ce que tu utilises tous tes doigts pour taper rapidement au clavier? Si c'est le cas, tu es excès de vitesse par conséquent tu ne contrôles pas exactement ce que tu tapes.De quoi parles tu ? Je n'ai pas compris le sens de ta phrase ?
Je tape toujours avec mes 10 doigts depuis des années et ça, 48 heures par semaine
(désolé pour la faute de frappe).
Tant mieux pour toi d'utiliser tes 10 doigts. Ce n'est pas mon cas, je tape comme les flics, les indexes uniquement. Mais je fais rarement des fautes surtout en écrivant du code.Je tape toujours avec mes 10 doigts depuis des années et ça, 48 heures par semaine
Je pige pas, tu dis "je ..." alors que tu nous as dis que le code venait de monsieur BOISGONTIER.Salut TooFatBoy
Initialement, j'allais faire un Redim Preserve Tt() d'où le ReDim Tt(1 To d.Count - 1, 1 To 31).
Sinon, le code aurait planté car j'ai déjà rencontré ce problème. @job75
Mais suite à la lecture d'un code de JB, je suis ravisé pour faire un peu plus simple.
J'ai donc juste ôter le Preserve et ça fonctionne sur ma bécane (win7 6 bits, Excel 2010 32 bits).
Bonjour,
: Je dis "je", car j'allais utiliser un Redim Preserve pour alimenter à chaque tour de boucles le tableau. C'est en consultant le site de Boisgontier que j'ai trouvé que dans certain de ces codes, il faisait des boucles pour déterminer au préalable les dimensions de son tableau. Et c'est ce que j'ai fais, mais j'ai juste supprimer le preserve du code initial.
C'est marrant que tu parles de ça parce que c'est aussi ce que j'envisage de faire dans un classeur sur lequel je travaille, pour voir si ça me fait gagner du temps d'exécution en évitant le Redim Preserve, qui doit bouffer pas mal de temps, à chaque boucle.
. Merci et bonne soirée
