Présentation sortie VB: fusion et bordures

Le 02/10/2023 à 19:50

Bonjour à tous,

J'ai réalisé une macro qui me sort bien ce que je veux.... c'est à dire les personnes qui doivent encore des heures d'animations.

Je galère pour présenter la réponse. La macro dont il est question est AnimDivers() qui écrit dans "Animations Divers".

10ap-anonyme.xlsm (124.88 Ko)

J'obtiens cette liste:

sans pre sentation

Et j'aimerais ça:

avec pre sentation

Pourriez vous m'aider??? D'autre part, je trouve que ma macro d'affichage est très longue à l'exécution... on peut optimiser??

Merci pour votre écoute.

Le 02/10/2023 à 20:12

Bonjour evolto, a tester

Sub CalculerHeuresManquantes()
    Dim feuille As Worksheet
    Dim ligne As Integer
    Dim derniereLigne As Integer
    Dim Enseignants As New Collection
    Dim Enseignant As Variant
    Dim HeuresManquantes As Double

    ' Référence à la feuille de calcul
    Set feuille = ThisWorkbook.Sheets("tableau AP")

    ' Trouver la dernière ligne dans la colonne D
    derniereLigne = feuille.Cells(feuille.Rows.Count, "D").End(xlUp).Row

    ' Parcourir les lignes de 9 à la dernière ligne
    For ligne = 9 To derniereLigne
        If feuille.Cells(ligne, 37) <> 0 Then
            ' Récupérer le nom de l'enseignant
            Enseignant = feuille.Cells(ligne, 4).Value

            ' Récupérer le nombre d'heures à ajouter
            HeuresManquantes = feuille.Cells(ligne, 37).Value

            ' Vérifier si l'enseignant est déjà dans la collection
            On Error Resume Next
            If Enseignants(Enseignant) = "" Then
                ' Ajouter l'enseignant à la collection avec le nombre d'heures manquantes
                Enseignants.Add HeuresManquantes, Enseignant
            Else
                ' Mettre à jour le nombre d'heures manquantes pour l'enseignant existant
                Enseignants(Enseignant) = Enseignants(Enseignant) + HeuresManquantes
            End If
            On Error GoTo 0
        End If
    Next ligne

    ' Afficher les enseignants et leurs heures manquantes
    For Each Enseignant In Enseignants
        MsgBox Enseignant & " doit encore " & Enseignants(Enseignant) & " heures d'animations."
    Next Enseignant
End Sub
Le 02/10/2023 à 20:43

Merci Stéphane pour ton retour...

Si j'ai bien compris, tu me proposes une optimisation de mon code???

En fait, ma principale demande est de présenter mes résultats (en fusionnant les noms d'école identique, faisant un quadrillage léger partout, et un cadre épais pour faire ressortir les blocs "Ecoles"... Je n'ai pas l'impression que ta macro fasse de la présentation dans feuille de sortie...

En tout cas merci de t''être penché sur mon cas...

Bonne soirée

Le 02/10/2023 à 20:57

J'ai pas bien compris alors a tester et c'est optimisé et l'autre aussi elle est optimisée 

Sub FormaterFeuille()
    Dim Feuille As Worksheet
    Dim DerniereLigne As Integer
    Dim Plage As Range
    Dim Cellule As Range
    Dim NomEcole As String

    ' Référence à la feuille de calcul
    Set Feuille = ThisWorkbook.Sheets("NomDeVotreFeuille")

    ' Trouver la dernière ligne en colonne A
    DerniereLigne = Feuille.Cells(Feuille.Rows.Count, "A").End(xlUp).Row

    ' Appliquer un quadrillage léger à toute la feuille
    Feuille.Cells.BorderAround xlContinuous, xlThin
    Feuille.Cells.Borders.LineStyle = xlContinuous
    Feuille.Cells.Borders.Weight = xlThin

    ' Parcourir les cellules en colonne A et fusionner celles avec le même nom d'école
    Set Plage = Feuille.Range("A1:A" & DerniereLigne)
    NomEcole = Plage.Cells(1, 1).Value
    For Each Cellule In Plage
        If Cellule.Value = NomEcole Then
            ' Fusionner les cellules avec le même nom
            Cellule.Offset(0, 1).Resize(1, 5).Merge
        Else
            ' Nouveau nom d'école, ajouter un cadre épais
            Cellule.BorderAround xlContinuous, xlThick
            NomEcole = Cellule.Value
        End If
    Next Cellule
End Sub
Le 02/10/2023 à 21:10

Tu peux faire la première macro et à la fin de ça de la première macro tu mets le nom de la macro pour formater.

 Next Enseignant
FormaterFeuille
End Sub
Application.ScreenUpdating = False
Application.ScreenUpdating = True

+ ça au début de la première macro et à la fin de la deuxième macro

Le 02/10/2023 à 21:20

Merci encore pour ton aide...

Malheureusement ce ne ne fonctionne pas du tout (Cela fusionne horizontalement le nom avec la colonne de droite, mais pas les noms d'école)...

Et cela applique un quadrillage sur toute la feuille... alors que je ne voulais appliquer ce quadrillage qu'aux données ajoutées par la macro sur la feuille.

Le 02/10/2023 à 21:37

Aucune des deux macros ne fonctionnennt ni ensemble, ni indépendamment...

Encore merci de t'être penché sur mon petit soucis

Le 02/10/2023 à 23:31

bonjour evolto,stepaustras,

comme ceci ?

Sub Fusionner()
     Set dict = CreateObject("Scripting.dictionary")
     dict.comparemode = vbTextCompare
     Application.ScreenUpdating = False
     With Sheets("Animations Divers")
          On Error Resume Next
          .AutoFilter.Range.AutoFilter
          On Error GoTo 0
          With .Range("A8:A" & .Range("A" & Rows.Count).End(xlUp).Row).Resize(, 18)     'vos données + entête
               For i = 2 To .Rows.Count      'boucler la colonne A
                    s = .Cells(i, 1).Value   'école
                    If s <> "" And Not dict.exists(s) Then     'nouvelle école ?
                         dict(s) = 0
                         .AutoFilter 1, s    'filtrer
                         b = False
                         For Each ar In .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlVisible).Areas
                              If b = False Then i = i + ar.Rows.Count - 1: b = True
                              Application.DisplayAlerts = False
                              ar.Merge       'fusionner
                              Application.DisplayAlerts = True
                              For Each brder In Array(xlEdgeBottom, xlEdgeTop)     'ces 2 bordures
                                   ar.Resize(, 20).Borders(brder).Weight = xlMedium
                              Next
                              For Each brder In Array(xlInsideHorizontal, xlInsideVertical)     'ces 2 bordures
                                   ar.Resize(, 20).Borders(brder).Weight = xlThin
                              Next
                         Next
                    End If
               Next
               .AutoFilter
          End With
     End With
End Sub
Le 03/10/2023 à 00:38

re sauf que je galère avec ces fichus bordures sinon ça fait le job 

Sub FusionnerCellulesAvecBordures()
    Dim Feuille As Worksheet
    Dim DerniereLigne As Long
    Dim LigneDebut As Long
    Dim LigneFin As Long
    Dim i As Long
    Dim ValeurPrecedente As Variant

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    Set Feuille = ThisWorkbook.Sheets("Animations Divers") 

    DerniereLigne = Feuille.Cells(Feuille.Rows.Count, "A").End(xlUp).Row
    LigneDebut = 9 ' Commencer à partir de la ligne 9

    ValeurPrecedente = Feuille.Cells(LigneDebut, "A").Value

    For i = LigneDebut + 1 To DerniereLigne
        If Feuille.Cells(i, "A").Value <> ValeurPrecedente Then
            If LigneFin > 0 Then
                ' Fusionner les cellules et appliquer le contour épais à la plage
                With Feuille.Range(Feuille.Cells(LigneDebut, "A"), Feuille.Cells(LigneFin, "A"))
                    .Merge
                    .Borders.LineStyle = xlContinuous ' Bordure continue
                    .Borders.Weight = xlMedium ' Épaisseur des bordures
                End With
                LigneFin = 0
            End If
            LigneDebut = i
            ValeurPrecedente = Feuille.Cells(i, "A").Value
        Else
            LigneFin = i
        End If
    Next i

    ' Fusionner les dernières cellules si nécessaire et appliquer le contour épais
    If LigneFin > 0 Then
        With Feuille.Range(Feuille.Cells(LigneDebut, "A"), Feuille.Cells(LigneFin, "A"))
            .Merge
            .Borders.LineStyle = xlContinuous
            .Borders.Weight = xlMedium
        End With
    End If

    ' Appliquer des bordures légères aux autres cellules
    Feuille.Range("A9:O" & DerniereLigne).Borders.LineStyle = xlContinuous ' Bordure continue
    Feuille.Range("A9:O" & DerniereLigne).Borders.Weight = xlThin ' Épaisseur des bordures

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Le 03/10/2023 à 00:48

Re bien joué BsAlv,

Le 03/10/2023 à 11:02

Merci Bart, ta procédure fonctionne impeccablement le top.

Merci Stéphane aussi

Rechercher des sujets similaires à "presentation sortie fusion bordures"