XL 2013 RechercheV avec recopie MFC sur une plage de cellules

[Tomobilus]

Bonjour le forum,

Après plusieurs recherches sur internet je n'arrive pas à trouver solution à mon problème.

J'ai actuellement un tableau sur la feuil2 qui regroupe toutes les mises en formes (entre la colonne H et Y) en fonction du résultat dans la colonne AA catégories.

Je voudrais pouvoir compléter automatiquement dans la feuil1 la mise en forme des colonnes H et Y lorsqu'un numéro est inscrit dans la colonne AA catégories (Faire correspondre la bonne mise en forme en fonction du numéro inscrit).

PS : Les "x" inscrits sur la feuil1 ne doivent pas s'effacer lors de la mise en forme.

voici le fichier en question.

Merci de l'aide que vous pourriez m'apporter.

 

[job75]

Bonjour Tomobilus,

La macro dans le code de Feuil1 (clic droit sur l'onglet et Visualiser le code) :

Private Sub Worksheet_Activate()
Dim mem, i&
Application.ScreenUpdating = False
With [H2].CurrentRegion
    .Cells(2, 1).Resize(Rows.Count - 1, 18).Interior.ColorIndex = xlNone 'RAZ
    mem = .Formula 'mémorisation
    For i = 2 To .Rows.Count
        If Val(.Cells(i, 20)) >= 1 Then Feuil2.Cells(Val(.Cells(i, 20) )+ 1, "H").Resize(, 18).Copy .Cells(i, 1)
    Next
    .Formula = mem 'restitution des formules et valeurs
End With
End Sub

Elle s'exécute quand on active la feuille.

A+

 

[Tomobilus]

Bonjour job75,

Merci de ta réponse rapide, à priori cella fonctionne parfaitement je te tiens au jus si j'ai des problèmes dans mon fichier d'origine.

Encore merci.
A+

 

[job75]

Re,

1) Chez moi sur Win 10 Excel 2013 j'obtiens des bordures épaisses en Feuil1 pour les catégories 3 et 8.

Je comprends bien pour la catégorie 8 mais pas du tout pour la catégorie 3.

Observez-vous la même chose si vous avez une autre version Excel ?

2) Pour la RAZ initiale il faut aussi effacer les bordures, je complète la macro :

Private Sub Worksheet_Activate()
Dim i&, mem
Application.ScreenUpdating = False
With [H2].CurrentRegion
    With .Cells(2, 1).Resize(Rows.Count - 1, 18)
        .Interior.ColorIndex = xlNone 'RAZ
        .Borders.LineStyle = xlNone 'RAZ
        For i = 7 To 10: .Borders(i).Weight = xlThin: Next 'contour
    End With
    mem = .Formula 'mémorisation
    For i = 2 To .Rows.Count
        If Val(.Cells(i, 20)) >= 1 Then Feuil2.Cells(Val(.Cells(i, 20)) + 1, "H").Resize(, 18).Copy .Cells(i, 1)
    Next
    .Formula = mem 'restitution des formules et valeurs
End With
End Sub

Fichier (2).

A+

 

[Tomobilus]

Bonjour Job75,

J'ai récupéré ta V2 que tu m'as envoyé, je n'avais pas les problème de bordures épaisses.

Par contre sur mon fichier final cela ne s'applique pas du tout...
Je ne comprend pas ce qu'il y a de différent..

J'ai juste remarqué qu'une ligne se tracé entre la colonne R et S

Le voici sans les données sensibles.

Je te remercie d'avance.

 

[job75]

Bonjour Tomobilus,

J'ai un peu modifié la macro pour que les "9" s'affichent, ceci fonctionne bien chez moi :

Private Sub Worksheet_Activate()
Dim mem, i&
Application.ScreenUpdating = False
With [H1].CurrentRegion.Resize(, 18)
    With .Cells(2, 1).Resize(Rows.Count - 1, 18)
        .Interior.ColorIndex = xlNone 'RAZ
        .Borders.LineStyle = xlNone 'RAZ
    End With
    mem = .Formula 'mémorisation
    For i = 2 To .Rows.Count
        If .Cells(i, 19) = "PARTI" Then .Cells(i, 20) = 9
        If Val(.Cells(i, 20)) >= 1 Then Feuil6.Cells(Val(.Cells(i, 20)) + 1, "H").Resize(, 18).Copy .Cells(i, 1)
    Next
    .Formula = mem 'restitution des formules et valeurs
End With
End Sub

Le fichier (3) en retour.

A+

 

[Tomobilus]

Re Job75,

Merci pour ton correctif, je n'arrive pas à télécharger le fichier que tu as joint (erreur pièce jointe non-trouvée)

Mais en copiant le code cela fonctionne bien cependant, est ce qu'il existe une solution pour éviter de recharger la page en entier à chaque fois qu'on ouvre la feuille GENERAL ? à la manière d'une rechercheV qui s'actualise automatiquement.

EDIT : j'ai réussi à le télécharger

 

[job75]

Re,

La macro précédente est simple et facile à comprendre mais son exécution prend du temps.

Celle-ci va bien plus vite mais elle est plus difficile à comprendre :

Private Sub Worksheet_Activate()
Dim mem, n&, i As Variant, h&
Application.ScreenUpdating = False
With [H1].CurrentRegion.Resize(, 18)
    With .Cells(2, 1).Resize(Rows.Count - 1, 18)
        .Interior.ColorIndex = xlNone 'RAZ
        .Borders.LineStyle = xlNone 'RAZ
    End With
    mem = .Formula 'mémorisation
    If Application.CountBlank(.Columns(20)) Then .Columns(20).SpecialCells(xlCellTypeBlanks) = 9
    .Cells(1, 21) = 1
    .Columns(21).DataSeries 'colonne auxiliaire numérotée
    .Resize(, 21).Sort .Columns(20), Header:=xlYes 'tri pour regrouper les lignes
    For n = 1 To Application.Max(Feuil6.Columns("AA"))
        i = Application.Match(n, .Columns(20), 0)
        If IsNumeric(i) Then
            h = Application.CountIf(.Columns(20), n)
            Feuil6.Cells(n + 1, "H").Resize(, 18).Copy .Cells(i, 1).Resize(h, 18)
        End If
    Next
    .Resize(, 21).Sort .Columns(21), xlAscending, Header:=xlYes 'tri pour rétablir l'ordre initial
    .Columns(21).ClearContents
    .Formula = mem 'restitution des formules et valeurs
End With
End Sub

Fichier (4).

A+

 

[Tomobilus]

Re job75,

C'est parfait!! t'es un magicien pour moi, tu fais des trucs de dingue

Un énorme merci

 

[job75]

Re,

Propriété des tris : les formats suivent sauf les bordures.

Avec le 1er tri la ligne 105 est déplacée en bas du tableau et aucune bordure ne lui est appliquée.

A+