Récupérer Dates de début et fin d'une action dans un calend
*rier
Bonjour cher membres du forum !
J'ai ici un listing d'actions par personnes avec les dates où ils y sont affectés.
J'ai déjà récupéré le nombre de jours par action et par personnes, j'aimerais maintenant avoir en plus le premier et dernier jour de chaque action.
J'ai pensé à une boucle où il faudrait voir les blocs contigües de cellules vides et non vides, mais je n'arrive pas à avoir toutes les dates, en particulier quand une même personne a fait plusieurs actions, comme pour ma personne "B. A." Voici ce que j'avais tenté (sachant que diverses variables sont définie en amont). Ces dates seront à copier au sein d'un autre tableau comprenant les 5 colonnes action (alpha, etc...) et le nom des personnes en ligne.
With ThisWorkbook.Sheets("TEMP")
For l = 2 To derligne_TCD
If .Cells(l, 1).Value Like "Total*" Then
If .Cells(l, 3).Value <> "" Then
If .Cells(l - 1, 3).Value <> "" Then
.Cells(l - 1, 2).Copy .Cells(l - 1, 10)
Else
If .Cells(l, 3) = "" Then
ActiveSheet.Cells(l - 1, 3).Copy .Cells(l - 1, 10)
Exit For
End If
End If
End If
If .Cells(l, 4).Value <> "" Then
If .Cells(l - 1, 4).Value <> "" Then
.Cells(l - 1, 2).Copy .Cells(l - 1, 10)
Else
If .Cells(l, 4) = "" Then
ActiveSheet.Cells(l - 1, 4).Copy .Cells(l - 1, 11)
Exit For
End If
End If
End If
If .Cells(l, 5).Value <> "" Then
If .Cells(l - 1, 5).Value <> "" Then
.Cells(l - 1, 2).Copy .Cells(l - 1, 10)
Else
If .Cells(l, 5) = "" Then
ActiveSheet.Cells(l - 1, 5).Copy .Cells(l - 1, 12)
Exit For
End If
End If
End If
If .Cells(l, 6).Value <> "" Then
If .Cells(l - 1, 6).Value <> "" Then
.Cells(l - 1, 2).Copy .Cells(l - 1, 10)
Else
If .Cells(l, 6) = "" Then
ActiveSheet.Cells(l - 1, 6).Copy .Cells(l - 1, 13)
Exit For
End If
End If
End If
If .Cells(l, 7).Value <> "" Then
If .Cells(l - 1, 7).Value <> "" Then
.Cells(l - 1, 2).Copy .Cells(l - 1, 10)
Else
If .Cells(l, 7) = "" Then
ActiveSheet.Cells(l - 1, 7).Copy .Cells(l - 1, 14)
Exit For
End If
End If
End If
End If
Next l
End With
Ci-joint un fichier exemple.
Merci
Bonjour,
Pas très clair... !
Et en mettant date début et date fin de chaque action, on aura directement les dates (!), le nombre de jours et le nombre d'actions, et en moins de lignes !!
Cordialement.
Bonjour,
Effectivement, malheureusement c'est une extraction d'un autre logiciel qu'on me donne, je suis donc condamné à jongler avec ce format peu pratique :/
L'idée serait donc, en partant des différentes cellules non vides des lignes "Total" de remonter et prendre la ligne de la première cellule non vide rencontrée (pour obtenir la date de fin dans la colonne B) puis remonter sur cette même colonne jusqu'à la dernière cellule non-vide (qui permettrait alors d'avoir la date de début).
J'imagine qu'il faut utiliser des boucles, mais j'avoue ne pas m'en sortir.
- Messages
- 1'794
- Excel
- 2010
- Inscrit
- 25/08/2014
- Emploi
- Consultant VB6 / SQL / VBA / Excel / Access
Bonjour,
Ci-joint une proposition à tester.
A priori, les données proviennent d'un TCD.
Si le fournisseur des données à la main sur le TCD, il pourrait directement donner ce résultat dans le TCD, ou fournir les données brutes pour ensuite construire le TCD qui va bien !
(même remarque que MFerrand, hello !)
Bonne journée
Bouben
Salut Bouben et Bonjour...
Il m'était venu à l'idée de faire une procédure pour reconstituer un tableau "origine"...
Cordialement et bonne journée à tous.
Bonjour,
Merci pour la macro, elle est bien plus élégante (et rapide !) que l'horreur que j'ai produit
J'ai pu voir la personne qui me fournit le fichier... en effet c'est bien une copie d'un TCD. En voici un extrait. Je ne sais pas si c'est plus simple à travailler qu'une copie de TCD du coup. Il y a beaucoup de colonnes non-utilisées dans cette base, puisqu'on ne prend que les noms, actions et dates.
Pour le format de rendu, je cherche à avoir un truc du style :
|Nom|Colonne Vide|Alpha|Beta|Delta|Gamma|Epsilon|Date de début|Date de Fin|Nombre de jours|
Ainsi que le nombre total de jours par action pour l'ensemble du personnel concerné (qui pourra être une dernière ligne avec "TOTAL" à la place du nom par exemple). La colonne vide me servira à étirer une formule d'INDEX EQUIV à partir d'une autre feuille que j'ai (ça ça marche par contre
Je vais bosser sur la macro, j'avais déjà compté les nombres de jours en partant du TCD avec l'horreur suivante :
With ActiveWorkbook.Sheets("TEMP")
.Columns("B:B").NumberFormat = "dd-mm-yyyy"
For i = 1 To derligne_TCD
If Cells(i, 1).Value Like "*Total*" Then
.Cells(i, 1).Copy ThisWorkbook.Sheets("PERSONNEL").Range("B" & derligne_Perso + 1)
Nom_debut = ThisWorkbook.Sheets("PERSONNEL").Range("B" & derligne_Perso + 1).Address
derligne_nom = ThisWorkbook.Sheets("PERSONNEL").Range("B" & Rows.Count).End(xlUp).Row
If .Cells(i, 3).Value <> "" Then
.Cells(i, 3).Copy ThisWorkbook.Sheets("PERSONNEL").Range("C" & derligne_Perso)
derligne_Perso = ThisWorkbook.Sheets("PERSONNEL").Range("C" & Rows.Count).End(xlUp).Row
End If
If .Cells(i, 4).Value <> "" Then
.Cells(i, 4).Copy ThisWorkbook.Sheets("PERSONNEL").Range("D" & derligne_Perso + 1)
derligne_Perso = ThisWorkbook.Sheets("PERSONNEL").Range("D" & Rows.Count).End(xlUp).Row
End If
If .Cells(i, 5).Value <> "" Then
.Cells(i, 5).Copy ThisWorkbook.Sheets("PERSONNEL").Range("E" & derligne_Perso + 1)
derligne_Perso = ThisWorkbook.Sheets("PERSONNEL").Range("E" & Rows.Count).End(xlUp).Row
End If
If Cells(i, 6).Value <> "" Then
.Cells(i, 6).Copy ThisWorkbook.Sheets("PERSONNEL").Range("F" & derligne_Perso + 1)
derligne_Perso = ThisWorkbook.Sheets("PERSONNEL").Range("F" & Rows.Count).End(xlUp).Row
End If
If Cells(i, 7).Value <> "" Then
.Cells(i, 7).Copy ThisWorkbook.Sheets("PERSONNEL").Range("G" & derligne_Perso + 1)
derligne_Perso = ThisWorkbook.Sheets("PERSONNEL").Range("G" & Rows.Count).End(xlUp).Row
End If
If Cells(i, 8).Value <> "" Then
.Cells(i, 8).Copy ThisWorkbook.Sheets("PERSONNEL").Range("J" & derligne_Perso)
Nom_fin = ThisWorkbook.Sheets("PERSONNEL").Range("J" & derligne_Perso).Address
derligne_Perso = ThisWorkbook.Sheets("PERSONNEL").Range("J" & Rows.Count).End(xlUp).Row + 2
End If
End If
Next i
End With
Bien sale. Et bien foireux, puisque pour ~5% des personnes j'avais un décalage dans le tableau que j'obtenais, j'avais donc fait un patch dégueulasse ajoutant des lignes vides puis dégageant les lignes sur-numéraires :
Application.Goto Sheets("PERSONNEL").Range("B1")
With ThisWorkbook.Sheets("PERSONNEL")
For j = 2 To derligne_Perso
If .Cells(j, 2).Value <> "" And .Cells(j, 3).Value = "" And .Cells(j, 4).Value = "" And .Cells(j, 5).Value = "" And .Cells(j, 6).Value = "" And .Cells(j, 7).Value = "" Then
.Cells(j - 1, 2).Value = .Cells(j, 2).Value
Rows(j).EntireRow.Delete shift:=xlUp
End If
If .Cells(j, 2).Value <> "" And .Cells(j - 1, 10) = "" And (.Cells(j - 1, 3).Value <> "" Or .Cells(j - 1, 4).Value <> "" Or .Cells(j - 1, 5).Value <> "" Or .Cells(j - 1, 6).Value <> "" Or .Cells(j - 1, 7).Value <> "") Then
.Cells(j - 1, 2).Value = .Cells(j, 2).Value
End If
Next j
For k = 2 To derligne_Perso
If .Cells(k, 2).Value = "" And .Cells(k, 3).Value = "" And .Cells(k, 4).Value = "" And .Cells(k, 5).Value = "" And .Cells(k, 6).Value = "" And .Cells(k, 7).Value = "" And .Cells(k, 10).Value = "" Then
Rows(k).EntireRow.Delete shift:=xlUp
End If
Next k
For k = 2 To derligne_Perso
If .Cells(k, 2).Value = "" And .Cells(k, 3).Value = "" And .Cells(k, 4).Value = "" And .Cells(k, 5).Value = "" And .Cells(k, 6).Value = "" And .Cells(k, 7).Value = "" And .Cells(k, 10).Value = "" Then
Rows(k).EntireRow.Delete shift:=xlUp
End If
If .Cells(k, 2).Value = "" And (.Cells(k - 1, 3).Value <> "" Or .Cells(k - 1, 4).Value <> "" Or .Cells(k - 1, 5).Value <> "" Or .Cells(k - 1, 6).Value <> "" Or .Cells(k - 1, 7).Value <> "") Then
.Cells(k, 2).Value = .Cells(k - 1, 2).Value
End If
Next k
derligne_Perso = ThisWorkbook.Sheets("PERSONNEL").Range("B" & Rows.Count).End(xlUp).Row
Rows(derligne_Perso).Delete shift:=xlUp
End With
Range("A2").AutoFill Destination:=Range("A2:A" & derligne_Perso - 1) 'etirement de l'index-equiv
Inutile d'essayer de repartir là dessus c'est hyper lourd et moche.
Je vais donc voir pour travailler un peu à partir de la macro de bouben pour réussir à obtenir ce que je veux
Je vois une coquille dans la macro :
Si une personnes n'a que deux dates et qu'elles sont non consécutives, alors on n'a pas une action qui va de la première à la seconde date mais deux actions qui durent une journée chacune.
Je ne vois pas trop où caser une condition pour éviter cet écueil. Je présume qu'il faut la mettre dans ce bloc :
For iLigPers = iLigPersDeb To iLigPersFin
If oShD.Cells(iLigPers, iColAction) <> "" Then
If dtDebAction = DT_AUCUNE Then
dtDebAction = oShD.Range("B" & iLigPers).Value
End If
dtFinAction = oShD.Range("B" & iLigPers).Value
End If
Next iLigPers
Edit : Je viens d'essayer de caser ceci, mais ça n'a pas l'effet escompté :
For iLigPers = iLigPersDeb To iLigPersFin
If oShD.Cells(iLigPers, iColAction) <> "" Then
If dtDebAction = DT_AUCUNE Then
dtDebAction = oShD.Range("B" & iLigPers).Value
End If
If (oShD.Range("B" & iLigPers).Value - 1) <> oShD.Range("B" & iLigPers - 1).Value And Not oShD.Range("A" & iLigPers - 1).Value Like "*Total*" Then
Else
dtFinAction = oShD.Range("B" & iLigPers).Value
End If
End If
Next iLigPers
Bonjour,
Une proposition à essayer :
Sub RécapActions()
Dim TAc(), act, n%, i%, j%, k%, f%, np$
With ActiveSheet
n = .Cells(.Rows.Count, 2).End(xlUp).Row
i = 3
Do
act = act & ";" & .Cells(2, i): i = i + 1
Loop Until .Cells(2, i) Like "Total*"
act = Split(act, ";"): f = UBound(act) + 3
ReDim TAc(f, 0)
For i = 3 To n
If .Cells(i, 2) <> "" Then
For j = 1 To UBound(act)
If .Cells(i, j + 2) = 1 Then Exit For
Next j
If j > UBound(act) Then j = 0
If .Cells(i, 1) <> "" Then
k = k + 1: ReDim Preserve TAc(f, k)
np = .Cells(i, 1): TAc(0, k) = np
TAc(f - 1, k) = .Cells(i, 2).Value2: TAc(f, k) = TAc(f - 1, k)
TAc(j + 1, k) = 1
Else
If .Cells(i, 2) = .Cells(i - 1, 2) + 1 And TAc(j + 1, k) > 0 Then
TAc(f, k) = .Cells(i, 2).Value2
TAc(j + 1, k) = TAc(j + 1, k) + 1
Else
k = k + 1: ReDim Preserve TAc(f, k): TAc(0, k) = np
TAc(f - 1, k) = .Cells(i, 2).Value2: TAc(f, k) = TAc(f - 1, k)
TAc(j + 1, k) = 1
End If
End If
End If
Next i
End With
For i = 1 To k - 1
For j = i + 1 To k
If TAc(0, j) < TAc(0, i) Then
For n = 0 To f
TAc(n, 0) = TAc(n, j): TAc(n, j) = TAc(n, i): TAc(n, i) = TAc(n, 0)
Next n
End If
Next j
Next i
k = k + 1: ReDim Preserve TAc(f, k): n = 0
TAc(0, 0) = "Nom Prénom": TAc(f - 1, 0) = "Date début": TAc(f, 0) = "Date fin"
For i = 1 To UBound(act)
TAc(i + 1, 0) = act(i)
For j = 1 To k - 1
n = n + TAc(i + 1, j)
Next j
TAc(i + 1, k) = n: n = 0
Next i
TAc(0, k) = "Total"
With Worksheets.Add(after:=ActiveSheet)
With .Range("A1").Resize(k + 1, f + 1)
.Value = WorksheetFunction.Transpose(TAc)
.HorizontalAlignment = xlCenter
With .Borders
.LineStyle = xlContinuous: .Weight = xlThin
End With
.Columns(1).ColumnWidth = 20
.Columns(f).NumberFormat = "dd/mm/yyyy"
.Columns(f + 1).NumberFormat = "dd/mm/yyy"
.Rows(k + 1).Font.Bold = True
.Rows(1).Font.Italic = True
End With
.Activate
End With
End Sub
Merci beaucoup,
Ça marche, et ça marche même très bien : macro concise (moins de 70 lignes) et exécution très rapide là où mon usine à gaz compte plus de 200 lignes pour un résultat insatisfaisant.
Apparemment ça fait appel à des variables tableaux, chose que je ne maitrise pas (confer ma signature). Je vais de ce pas lire quelques tutos pour combler ce manque.
Je vais modifier un peu le code afin que ça ne crée pas de nouvelle feuille mais que ça 'imprime' toujours sur la même -qui sera préalablement nettoyée en début de code)-.
Merci beaucoup pour votre aide à tous les deux.