Macro pur fusionner des lignes dont les dates se suivent
Bonjour
Voici ma problématique
A ce jour j'ai une extraction avec une liste de matricule ainsi que des dates d'absences pour ces matricules. Le souci est que j'ai parfois 2 lignes (ou 3,4,5,10 lignes...) pour un même matricule avec des dates qui se suivent.
Ce que je souhaiterais c'est une macro pour copier dans une nouvelle feuille la liste des matricules avec une ligne pour chaque absence avec la date de fin relle, soit supprimer les lignes intermédiaires pour ne faire apparaitre que les dates d 'absence de départ et de fin.
Par exemple j'ai :
une ligne avec un matricule 001 et absence du 7/09 au 21/09 puis une seconde ligne du matricule 001 et une absence du 22/09 au 5/10 puis une troisième ligne du 001 du 29/11 au 30/11, après ça passe au matricule 002...
J'aimerais seulement deux lignes dans le cas présent, une pour le 001 du 7/09 au 5/10 et une seconde ligne du 001 du 29/11 au 30/11 puis ainsi de suite avec chaque matricule
Vous trouverez ci joint l'exemple plus concrètement
Existerait-il une macro pour effectuer cette opération automatiquement svp?
Un grand merci pour votre aide
Bonjour,
voici une proposition. On peut sûrement faire mieux mais ça marche !
Sub macro()
'Recherche derniere ligne
Dim lastRow As Integer
lastRow = ActiveSheet.Range("C100000").End(xlUp).Row
'Init variables
Dim sheetName As String
Dim iRow, iRowResult As Integer
Dim mat, matPrec As String
Dim debut, debutPrec As Date
Dim fin, finPrec As Date
Dim nbJours As Integer
sheetName = ActiveSheet.Name
iRow = 1
iRowResult = 2
nbJours = 0
matPrec = ""
'Init onglet resultat et création si besoin
Dim topOngletExiste As Boolean
topOngletExiste = False
For Each oSheet In ThisWorkbook.Sheets
If oSheet.Name = "resultat" Then
topOngletExiste = True
End If
Next
If Not topOngletExiste Then
ThisWorkbook.Sheets.Add.Name = "resultat"
End If
ThisWorkbook.Sheets("resultat").Cells.ClearContents
ThisWorkbook.Sheets("resultat").Cells(1, 1).Value = "mat"
ThisWorkbook.Sheets("resultat").Cells(1, 2).Value = "debut"
ThisWorkbook.Sheets("resultat").Cells(1, 3).Value = "fin"
ThisWorkbook.Sheets(sheetName).Activate
'Parcours matricules
Do While iRow <= lastRow
mat = ActiveSheet.Cells(iRow, 1).Value
debut = ActiveSheet.Cells(iRow, 2).Value
fin = ActiveSheet.Cells(iRow, 3).Value
If IsDate(debut) Then
If matPrec <> "" Then
nbJours = debut - finPrec
End If
If nbJours <> 1 Or mat <> matPrec Then
ThisWorkbook.Sheets("resultat").Cells(iRowResult, 1).Value = mat
ThisWorkbook.Sheets("resultat").Cells(iRowResult, 2).Value = debut
ThisWorkbook.Sheets("resultat").Cells(iRowResult, 3).Value = fin
iRowResult = iRowResult + 1
Else
ThisWorkbook.Sheets("resultat").Cells(iRowResult - 1, 3).Value = fin
End If
matPrec = mat
debutPrec = debut
finPrec = fin
End If
iRow = iRow + 1
Loop
End Sub
Excellent, en effet ça fonctionne!! Merci
Je vais étudier ta macro pour l'adapter à mon fichier d'origine et la comprendre
Encore merci!