Macro VBA Fusionner des lignes et afficher le résultat en ordre croissant
Bonjour à tous et à toutes,
Je tiens à vous poser une question, s'il-vous-plaît.
J'ai un fichier avec une liste des personnes. Chaque personne a 3 lignes correspondantes à une différent type d'activité. Je travaille sur un macro qui permettrait pour chaque personne de fusionner les deux premières lignes et supprimer la troisième ligne.
Mon problème est qu'après la fusion des deux premières lignes, je souhaiterais classer le contenu dans l'ordre chronologique du matin au soir: d'abord 09h-11h,puis 10h-12h, puis 11h-13h, puis 14h-16h, puis 15h-17. Des fois j'ai des créneaux comme ça : 09h-12h, 14h-17h,09h-10h.
Est-ce que quelqu'un peut me guider, s'il-vous-plaît?
Je mets le fichier ci-joint. Juste les cases blanches sont concernées par le tri, car les cases colorées n'ont du contenu que sur la première ligne.
Merci par avance pour ce qui prendront le temps de me lire.
Bonjour
Un essai à tester. Te convient-il ?
Option Explicit
Dim tablo, tabloR()
Dim i&, j&, col&
Sub FusionnerEtClasser()
'on classe chaque groupe de 3 cellules de chaque nom
Application.ScreenUpdating = False
For j = 5 To 14
For i = 3 To Range("A" & Rows.Count).End(xlUp).Row - 2 Step 3
'Range(Cells(i, j), Cells(i + 2, j)).Select
If Cells(i + 1, j) <> "*" And Cells(i + 1, j) <> "" Then
On Error Resume Next
Range(Cells(i, j), Cells(i + 2, j)).Sort key1:=Cells(i, j), _
order1:=xlAscending, Header:=xlNo
End If
Next i
Next j
'Report du résultat dans une variable tableau
tablo = Range("A3:N" & Range("A" & Rows.Count).End(xlUp).Row)
ReDim tabloR(1 To UBound(tablo, 1) / 3, 1 To UBound(tablo, 2))
For j = 5 To UBound(tablo, 2)
For i = 1 To UBound(tablo, 1) - 2 Step 3
If tablo(i + 1, j) = "" Then
tabloR((i + 1) / 2, j) = tablo(i, j)
Else
tabloR((i + 1) / 2, j) = tablo(i, j) & vbLf & tablo(i + 1, j)
End If
For col = 1 To 4
tabloR((i + 1) / 2, col) = tablo(i, col)
Next col
Next i
Next j
'Report sur la feuille de calcul
With Range("A3:N" & Range("A" & Rows.Count).End(xlUp).Row)
.Interior.Color = xlNone
.VerticalAlignment = xlCenter
End With
Range("A3").Resize(UBound(tabloR, 1), UBound(tabloR, 2)) = tabloR
End SubBye !
Bonjour GMB,
Merci pour ton travail et ton retour. Je teste demain matin et je te confirme!
Bonjour GMB,
Merci beaucoup pour ce code, c'est vraiment le top du top et c'est exactement ce que je souhaiterais faire mais je n'arrivais pas! milles mercis.
Il me reste juste quelques derniers petits points de mise en forme à régler avant de terminer le travail sur ce fichier. Je ne sais pas si tu peux m'aider la dessus, s'il-te-plaît, ça m'arrangerait beaucoup. Je comprendrais si tu n'as pas le temps mais je tente ma chance.
Alors, concrètement j'aurais besoin :
-> d'afficher le résultat pour tous les services pas sur une même feuille mais plutôt sur plusieurs feuilles: une feuille par service si possible;
-> appliquer aux résultats la forme du tableau "Bleu, Style de tableau moyen 2" (c'est colonne 2 ligne 4 dans le choix des tableaux dans "Mettre sous forme de tableau");
-> supprimer les commentaires, enlever les couleurs, enlever les "*", enlever la mise en gras du texte, enlever les lettres "P" dans certaines cases. L'objectif est ne garder que les créneaux et les noms des activités indiquées dans certaines cases en alignant au centre le contenu des cases.
Je te remercie par avance pour tout ton aide.
Bonjour GMB,
Merci pour le code, c'est super. J'aurais aimé d'être à ton niveau un jour!
Je voulais rajouter un bout de macro manquant, c'est celui de l'application de la mise en forme du tableau TableStyleMedium2.
En procédant par l'enregistrement du macro, j'ai eu ce code.
Deux petits soucis par contre:
1) je ne vois pas où dans ton macro il faut rajouter "call Macro2" (car si je le mets avant le dernier Sub ça ne marche pas bien)
2) la mise en forme du tableau ne s'applique pas à la totalité du tableau qui se crée dans chaque onglet par service mais uniquement aux premières lignes...saurais-tu me guider, sur comment faire pour appliquer la forme du tableau TableStyleMedium2 sur tous les nouveaux onglets, stp?
Merci par avance...
Sub Macro2()
'
' Macro2 Macro
'
'
Range("A2:D2").Select
Selection.Cut Destination:=Range("A1:D1")
Range("A1:N3").Select
Application.CutCopyMode = False
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$N$3"), , xlYes).Name = _
"Tableau3"
Range("Tableau3[#All]").Select
ActiveSheet.ListObjects("Tableau3").TableStyle = "TableStyleMedium2"
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
End Sub
GMB,
C'est parfait pour moi!
Merci beaucoup pour ton aide!!!aussi rapide et efficace!
Bonne journée!
ah mince je viens de voir que si le nb de jours du planning excède 15 jours, le reste des jours ne sont pas affichés...dans l'exemple il y a 15 jours, mais en vrai ça peut être 30...
GMB bonsoir,
c'est encore moi, désolée.
je ne sais pas pourquoi mais quand je renomme mes services (je mets autres que Service1, Service2, etc) le macro ne marche plus. il mélange les services…
navrée de te déranger encore
merci pour ton retour, ça ne marche pas malheuresement, dans Orchidee, on retrouve Turquoise (au lieu de Orhidee) et pareil pour les autres onglets...et j'ai encore un autre problème, c'est qu'en allant au delà de la colonne Y, le classement des créneaux ne se fait plus. ca encore j'arriverai à corriger mais je n'arrive pas à corriger le problème de répartition des services...je vous envoie mon fichier de test des fois que vous pouvez m'aider la dessus pour terminer ce sujet...merci par avance...
Bonjour,
merci pour votre macro, ça marche très bien, vraiment top.
au cours de l'utilisation, je me suis aperçue qu'il serait plus pratique de générer les feuilles avec le résultat pas dans le même fichier mais dans un nouveau fichier.
Je souhaiterais ajouter votre macro dans le fichier ci-joint que j'ai déjà (avec d'autres macros) et que votre macro génère les mêmes feuilles de résultat qu'actuellement mais dans un fichier appart.
je comprendrais bien si vous souhaitiez passer à une autre chose et de ne plus travailler sur ce sujet.
merci pour m'avoir lu en tous cas...