Recopie cellules dans d'autres feuilles du même classeur avec mise en forme

Bonjour,

Steelson m'avait gentiment aider pour une macro, qui faisait le job, mais au bout de quelques jours, j'ai renvoyer un message à Steelson, ci dessous.

Bonjour Steelson,

Je sais pas si j'ai fait un bêtise, mais dans le classeur ALBUMS, dans "nouvel entrée", quand je clique sur le bouton "ajouté", il recopie bien dans la lettre approprié, mais pour les cellules qui sont en jaune, il me recopie bien le contenu mais ne recopie la mise en forme en l'occurrence les cellules jaune

Il a tester et ma répondu

Désolé, j'ai cherché et je ne comprends pas du tout pourquoi excel réagit comme cela ! J'ai mis des couleurs différentes à chaque colonne de nouvelle entrée, et Excel fait ce qu'il veut !

Quand on copie à la main c'est bon.

Donc si quelqu'un pouvais m'aider, ce serait super sympa

Je vous met ci-dessous le code VBA "Module 2" et en pièce jointe mon fichier simplifier

Merci pour votre aide

Sub AJOUTER()

For Each f In Worksheets
    With f.Tab
        .ColorIndex = xlNone
        .TintAndShade = 0
    End With
Next

Set plage = Range("A" & Rows.Count).End(xlUp).CurrentRegion
nbcol = plage.Columns.Count
If plage.Rows.Count < 3 Then Exit Sub
For i = 3 To plage.Rows.Count
    initiale = Left(plage.Cells(i, 1), 1)
    If IsNumeric(initiale) Then initiale = "0-9"

    With Sheets(initiale)
        plage.Cells(i, 1).Resize(1, nbcol).Copy Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        .ListObjects(1).Sort.Apply
        With .Tab
            .Color = 49407
            .TintAndShade = 0
        End With
    End With

Next

End Sub

Bonjour,

Merci d'avoir ajouté le fichier ...

Si l'on copie cellule par cellule > ça semble bien fonctionner ...

À moins d'avoir des milliers de lignes > il ne devrait pas y avoir un gros délai de plus ...

Option Explicit

Sub AJOUTER()
Dim Initiale As String
Dim x As Integer

   Application.ScreenUpdating = False

   For Each f In Worksheets
      With f.Tab
         .ColorIndex = xlNone
         .TintAndShade = 0
      End With
   Next

   Set plage = Range("A2").CurrentRegion

   nbcol = plage.Columns.Count

   If plage.Rows.Count < 3 Then Exit Sub

   For I = 3 To plage.Rows.Count
      Initiale = Left(plage.Cells(I, 1), 1)
      If IsNumeric(Initiale) Then Initiale = "0-9"

      With Sheets(Initiale)
         nl = .Cells(Rows.Count, "A").End(xlUp).Row + 1
         For x = 1 To nbcol
            plage.Cells(I, x).Copy .Cells(nl, x)
         Next x

         .ListObjects(1).Sort.Apply   ' ???

         With .Tab
            .Color = 49407
            .TintAndShade = 0
         End With
      End With
   Next
End Sub

ric

Bonsoir,

J'ai essayé un truc, j'ai refait le tableau sur un classeur propre est ca à l'air de remarcher

Merci d'avoir regarder

Bonjour,

willy95 a écrit :

Bonsoir,

J'ai essayé un truc, j'ai refait le tableau sur un classeur propre est ca à l'air de remarcher

Merci d'avoir regarder

Après avoir lu ce commentaire > j'ai repris ton fichier > j'ai supprimé toutes les lignes des tableaux des feuilles : "0-9, A, B" et renommé le tableau de la feuille "B" ...

Après ces changements > la macro d'origine fonctionne correctement ...

ric

Merci ric d'avoir pris le temps de tester le fichier,

Oui je confirme la macro refonctionne correctement

Bon week-end