XL 2013 consolidation données

[mix770]

Bonjour le Forum,
j'ai besoin d'aide et surtout de vos talents

j'ai un tableau Excel avec 12 mois et 30 lignes, sur chaque mois j'ai besoin de collecter sur un tableau les personnes qui ont un motif d'absence sur 2 codes (CAP-IMJ) et les périodes.
voir PJ, explication, une personne peut avoir été absente la première semaine et la troisième sur ce code cela veut dire qu'il faut autant de ligne que de plage d'absence.
ex: absent code cap du 2 au 20 janvier une ligne, si coupure dans la période une nouvelle ligne.


je cherche au plus simple, je mettrai un tableau par mois il reporte le code sur la ligne dans ce tableau je fais une recherche v pour associer l'intitulé au code.

je sais que je demande beaucoup, je suis désolé mais je coince.

merci beaucoup à vous,

 

[job75]

Bonsoir mix770,

j'ai un tableau Excel avec 12 mois et 30 lignes

Ce n'est pas du tout ce qui apparaît sur le fichier joint.

A+

 

[mix770]

bonjour,
en fait j'ai détaché un seul mois et le modèle de support de collecte pour ne pas avoir un fichier trop lourd. je pensais dupliquer après la proposition
dit moi ce que tu en penses

 

[mix770]

Bonjour le Forum,
suite à la remarque pertinente de Job 75, j'ai mis les 12 mois et les 12 tableaux sur un autre onglet.
avec explication sur mes points de blocage.
merci beaucoup à vous

 

[mix770]

J'avais un VBA sur un tableau qui allait sur le mois et inscrivait pour 1 nom l'ensemble des absences toujours à partir de code et les dates début et fin.
je sais pas s'il y a possibilité de le convertir pour ce tableau si la solution doit passer par un VBA.


Sub Collecte(ByVal FCbl As Worksheet)
Dim FSrc As Worksheet, Cel As Range, Déb As Date, Te(), Codes(), Périodes(), DCV As New Dictionary, _
Valide As Boolean, L As Long, j As Long, Jp As Long, CodCou As String, CodSui As String
On Error Resume Next
Set FSrc = ThisWorkbook.Worksheets(FCbl.[AD4].Value)
If Err Then MsgBox "Feuille """ & FCbl.[AD4].Value & """ introuvable.", vbCritical, "Collecte": Exit Sub
On Error GoTo 0
Te = FCbl.Range("U2:U" & FCbl.[U500].End(xlUp).Row).Value
For L = 1 To UBound(Te)
If Not IsEmpty(Te(L, 1)) Then DCV(UCase(Te(L, 1))) = 0
Next L
Déb = FSrc.[C8].Value - 1
Set Cel = FSrc.[A9:A88].Find(What:=FCbl.[C7].Value, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Cel Is Nothing Then MsgBox Feuil109.[C7].Value & " inexistant.", vbCritical, "Collecte": Exit Sub
Te = Cel.Offset(, 2).Resize(, 32).Value
ReDim Codes(1 To 19, 1 To 1), Périodes(1 To 19, 1 To 2)
L = 0: j = 1: CodSui = UCase(Te(1, 1))
Do ' Début code
CodCou = CodSui: Valide = DCV.Exists(CodCou)
If Valide Then L = L + 1: Codes(L, 1) = CodCou: Périodes(L, 1) = Format(Déb + j, "dd mmm yyyy")
Do: If j >= 32 Then Exit Do
j = j + 1: CodSui = UCase(Te(1, j)): Loop Until CodSui <> CodCou
' Fin code
If Valide Then Périodes(L, 2) = Format(Déb + j - 1, "dd mmm yyyy")
Loop Until j >= 32
FCbl.[A13].Resize(19, 1).Value = Codes
FCbl.[C13].Resize(19, 2).Value = Périodes
Dim Nom As String, NomFeui As String, FeuiNom As Worksheet
Nom = FCbl.[C7].Value
NomFeui = "Nom " & (Cel.Row - 9) \ 2 + 1
On Error Resume Next
Set FeuiNom = ThisWorkbook.Worksheets(NomFeui)
If Err Then MsgBox "Feuille """ & NomFeui & """ introuvable.", vbCritical, "Collecte": Exit Sub
On Error GoTo 0
If FeuiNom.[B5].Value <> Nom Then MsgBox "Attention, " & NomFeui & "!B5 contient """ & _
FeuiNom.[B5].Value & """ au lieu de """ & Nom & """.", vbExclamation, "Collecte"
FCbl.[G35:R42].Value = FeuiNom.[C41:N48].Value
Range("G13:O14").Select
ActiveCell.FormulaR1C1 = _
"=IF(R[-6]C[-4]=0,"""",(VLOOKUP(R[-6]C[-4],Tables!R[-10]C[27]:R[97]C[28],2,FALSE)))"

 

[job75]

Bonsoir mix770,

Il faudrait mettre quelques absences dans 2 ou 3 feuilles des mois.

Histoire de savoir comment vous voulez repérer les périodes des absences.

Par ailleurs dans la feuille "Format_Act_P" est-il indispensable d'avoir 12 tableaux ?

En effet un seul tableau avec le mois modifiable peut suffire.

A+

 

[mix770]

Bonsoir Job75,

Oui pas de problème je vais mettre des codes et aussi des heures travaillées
pas de Pb pour un seul tableau si c'est faisable et plus simple.

j'envoie ça tout de suite

merci beaucoup

 

[mix770]

Job75,
je poste le tableau

 

[job75]

Voyez le fichier joint et ces 2 macros dans le code de la feuille "Format_Act_P" :

Private Sub Worksheet_Activate()
Worksheet_Change [A1] 'lance la macro
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim mois$, P As Range, w As Worksheet, an, i&, j%, c As Range, n&, k%
mois = LCase(CStr([C11]))
Set P = Range("C14:H" & Rows.Count)
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next 'sécurrité
P.Clear 'RAZ
If mois = "" Then GoTo 1
For Each w In Worksheets
    If LCase(CStr(w.Range("P3"))) = mois Then Exit For
Next w
If w Is Nothing Then GoTo 1
an = w.Range("U3")
If Not IsNumeric(CStr(an)) Then an = Year(Date)
For i = 9 To w.Range("A1", w.UsedRange).Rows.Count
    If w.Cells(i, 1) <> "" And Not w.Rows(i).Hidden Then
        For j = 3 To 33
            Set c = w.Cells(i, j)
            If Not IsNumeric(c) And c <> c(1, 0) Then
                n = n + 1
                P(n, 1) = w.Cells(i, 1) 'Nom Prénom
                P(n, 2) = c 'Code
                P(n, 4) = CDate(j - 2 & "/" & mois & "/" & an) 'Du...
                k = 2
                While c(1, k) = c: k = k + 1: Wend
                P(n, 5) = P(n, 4) + k - 2 'Au...
                j = j + k - 2
            End If
        Next j
    End If
Next i
If n Then
    With P.Resize(n)
        .Columns(3) = "=IFERROR(VLOOKUP(RC[-1],Recherche_Code,2,0),"""")"
        .Columns(6) = "=NETWORKDAYS(RC[-2],RC[-1])"
        .Columns(4).Resize(, 3).HorizontalAlignment = xlCenter 'centrage
        .Borders.Weight = xlHairline 'bordures
    End With
End If
1 Application.EnableEvents = True
End Sub

Le tableau est recréé automatiquement quand on modifie une cellulee quelconque ou quand on active la feuille.

Pour tester choisissez le mois de Janvier dans la liste en C11.

Bonne nuit.

 

[mix770]

merci Job45,
je regarde à la première heure demain
merci beaucoup, je reviens vers toi

 

[mix770]

Job75,
j'ai pas pu résister, ça a l'air top, juste sur le tableau il ne faut qu'il n'apparaisse que les 2 code CAP et IMJ. c'est un traitement particulier pour ces codes.
les autres absences sont traitées autrement.
tu penses que l'on peut réduire à ces 2 codes ?
sinon le reste parfait
merci beaucoup à toi,

 

[job75]

Bonjour mix770, le forum,

Avec ce fichier (2) on se limite aux codes CAP et IMJ.

J'en ai profité pour utiliser 2 tableaux VBA, c'est bien plus rapide :

Private Sub Worksheet_Activate()
Worksheet_Change [A1] 'lance la macro
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim mois$, P As Range, w As Worksheet, an, tablo, resu, i&, j%, x$, n&, k%
mois = LCase(CStr([C11]))
Set P = Range("C14:H" & Rows.Count)
Application.ScreenUpdating = False
Application.EnableEvents = False
P.Clear 'RAZ
If mois = "" Then GoTo 1
For Each w In Worksheets
    If LCase(CStr(w.Range("P3"))) = mois Then Exit For
Next w
If w Is Nothing Then GoTo 1
an = w.Range("U3")
If Not IsNumeric(CStr(an)) Then an = Year(Date)
tablo = w.Range("A1", w.UsedRange).Resize(, 35).Formula 'matrice, plus rapide
resu = P 'matrice, plus rapide
For i = 9 To UBound(tablo)
    If tablo(i, 1) <> "" Then
        For j = 3 To 33
            x = UCase(tablo(i, j))
            If x = "CAP" Or x = "IMJ" Then 'critères
                n = n + 1
                resu(n, 1) = tablo(i, 1) 'Nom Prénom
                resu(n, 2) = x 'Code
                resu(n, 4) = CDate(j - 2 & "/" & mois & "/" & an) 'Du...
                k = 1
                While UCase(tablo(i, j + k)) = x: k = k + 1: Wend
                resu(n, 5) = resu(n, 4) + k - 1 'Au...
                j = j + k - 1
            End If
        Next j
    End If
Next i
'---restitution---
If n Then
    With P.Resize(n)
        .Value = resu
        .Columns(3) = "=IFERROR(VLOOKUP(RC[-1],Recherche_Code,2,0),"""")"
        .Columns(6) = "=NETWORKDAYS(RC[-2],RC[-1])"
        .Columns(4).Resize(, 3).HorizontalAlignment = xlCenter 'centrage
        .Borders.Weight = xlHairline 'bordures
    End With
End If
1 Application.EnableEvents = True
End Sub

J'ai testé en recopiant les lignes 9 à 18 de la feuille Janvier sur 10 000 lignes.

Chez moi la macro s'exécute en 0,53 seconde.

A+

 

[mix770]

Bonjour Job75,
c'est magnifique, merci beaucoup à toi, respect pour le niveau de maitrise.
bien cordialement

 

[mix770]

re Job75,

j'ai intégré le tout dans mon tableau, c'est parfait, j'ai juste 2 Pb.
1) ce tableau est protégé par une macro qui protège tous les onglets, donc quand la protection est engagée, ce la bloque la macro. au niveau "
"P.Clear 'RAZ"
je pense que l'on peut intégrer dans la macro un déverrouillage en début et verrouillage en fin, je ragerde cet AM.
2) sur les mois ex janvier il y a nom1, nom2,etc. entre il y a une ligne blanche qui est destinée à mettre le nom d'un remplaçant. Quand ce nom est associé à un des 2 codes cela s'affiche c'est top.

je voulais différencier dans l'onglet "format act p" ces lignes car les nom seront précédés de CCD ou INT. j'ai fait une mfc qui reconnais les intitulés et cela marche, mais à chaque nouvelle recherche la mfc est effacées.
c'est ce qu'il y avait de plus simple pour moi de passer par une mfc que de faire une lecture une ligne sur 2 (nom ou nom cdd).

je dois partir, mais je reviens ce soir avec un exemple
merci encore à toi

 

[job75]

Pour régler ces 2 problèmes de protection et de MFC remplacez :

P.Clear 'RAZ

par ces 3 lignes :

Protect "toto", UserInterfaceOnly:=True 'mot de passe toto à adapter
P.ClearContents 'RAZ
P.Borders.LineStyle = xlNone 'RAZ

Et bien sûr déverrouillez la cellule C11 avant que la feuille soit protégée.