XL 2013 Copier avec mise en forme conditionnelle

S

sr94

XLDnaute Occasionnel
Bonjour

Je suis toujours sur le même fichier, avec ma macro qui me permet de scinder mon classeur en plusieurs.
Je ne peux pas mettre de pièce jointe, la fichier est trop lourd.

Cette macro permet de copier les données filtrées dans une feuille temporaire, la copie ne prend pas en compte les mises en forme conditionnelles et les formules, est ce possible de modifier le code en dessous pour qu'il les prenne en compte ?

Code: 
For Each c In Range("AJ5", Range("AJ100").End(xlUp))

PlageExtract = c
Sheets.Add
Data.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Production_Schedule").[AJ4:AJ5], CopyToRange:=[A1], Unique:=False
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$AC$2000"), , xlYes).Name = "tab_Production_Schedule"

Merci
 
Dernière édition:
Trier par date Trier par votes
S

sr94

XLDnaute Occasionnel
Re : Copier avec mise en forme conditionnelle

J'ai réessayer ce matin, ça marche ... je devais être mal réveillée hier.

Il reste juste la colonne A qui est une RECHERVEV, soit il faut copier/coller les valeurs pour éliminer la RECHERCHEV à la création, sinon rompre les liaisons du fichier créé a l'air de marcher aussi, que peut on rajouter avant le saveas ?

Merci encore !
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Copier avec mise en forme conditionnelle

Bonjour sr94, le forum,

Pas bien clair, mais je suppose que vous voulez parler de la colonne A des fichiers créés donc de Col4.

S'il y a le message lors de l'ouverture du fichier de la macro, il suffit de rompre la liaison manuellement.

Si vous ne voulez pas rompre la liaison vous pouvez utiliser :

Code: 
Sub Production_Schedule()
Dim F As Worksheet, t, d As Object, i&, liste, chemin$
Dim e, critere$, tf, ncol%, n&, txt$, j%
Set F = Feuil1 'CodeName de la feuille
'---supprime (provisoirement) les formules en colonne D---
With F.ListObjects(1).DataBodyRange
  ThisWorkbook.Save 'enregistrement, à retirer si toujours inutile
  .Columns(4) = .Columns(4).Value
  t = .Value 'matrice
End With
'---liste des partenaires sans doublon---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 1 To UBound(t)
  If t(i, 8) <> "" Then d(t(i, 8)) = ""
Next i
If d.Count = 0 Then Exit Sub
liste = d.keys
'---création des fichiers---
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier existe déjà
chemin = ThisWorkbook.Path & "\" 'à adapter
For Each e In liste
  critere = UCase(e) 'majuscules
  With Workbooks.Add.Sheets(1) 'nouveau document
    F.ListObjects(1).Range.Copy .[A1]
    .[A1].Copy .[A1] 'vide la mémoire
    .ListObjects(1).Range.Columns("AG:AH").Delete
    .ListObjects(1).Range.Columns("A:C").Delete
    With .ListObjects(1).DataBodyRange
      t = .Value 'matrice des valeurs, plus rapide
      tf = .FormulaR1C1 'matrice des formules
      ncol = UBound(t, 2)
      d.RemoveAll 'RAZ
      n = 0
      For i = 1 To UBound(t)
        If UCase(t(i, 5)) = critere Then
          txt = ""
          For j = 1 To ncol
            txt = txt & Chr(1) & IIf(IsError(t(i, j)), "", t(i, j))
          Next j
          If Not d.exists(txt) Then 'pour éliminer les lignes doublons
            d(txt) = ""
            n = n + 1
            For j = 1 To ncol
              t(n, j) = tf(i, j)
            Next j
            t(n, 5) = critere 'facultatif, nom du partenaire en majuscules
          End If
        End If
      Next i
      If n Then .Resize(n).FormulaR1C1 = t 'restitution
      If n < .Rows.Count Then .Rows(n + 1 & ":" & .Rows.Count).Delete
    End With
    .Columns.AutoFit 'ajustement de la largeur
    .Columns("C:D").Hidden = True
    critere = Replace(Replace(Replace(Replace(Replace(critere, "/", "_"), "&", "_"), "...", "_"), ".", "_"), " ", "_")
    critere = chemin & "fichier_partenaire_" & critere & "_" & Format(Date, "d-mm-yy")
    .Parent.SaveAs critere, FileFormat:=51 'fichier .xlsx
    .Parent.Close
  End With
Next e
'---rouvre le fichier pour restituer les formules en colonne D---
Workbooks.Open ThisWorkbook.FullName
End Sub
txt = txt & Chr(1) & IIf(IsError(t(i, j)), "", t(i, j)) évite le bug s'il y a des valeurs d'erreur dans le tableau.

A+
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Copier avec mise en forme conditionnelle

Re,

Une simplification pour éviter les valeurs d'erreur, au lieu de :

Code: 
txt = txt & Chr(1) & IIf(IsError(t(i, j)), "", t(i, j))
écrire :

Code: 
txt = txt & Chr(1) & CStr(t(i, j))
C'est même mieux car dans la recherche de doublon ce code distingue les erreurs différentes...

A+
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Copier avec mise en forme conditionnelle

Re,

Ce qui prend beaucoup de temps c'est la copie du tableau Excel :

Code: 
F.ListObjects(1).Range.Copy .[A1]
Chez moi (Excel 2013) environ 4 secondes sur le petit tableau de votre fichier (post #2).

Et ceci pour chaque fichier créé (chaque partenaire).

Pour améliorer ça peut-être faudrait-il ne pas utiliser des tableaux Excel.

Edit : non pas du tout, j'ai converti le tableau Excel en plage, la copie du tableau prend le même temps.

Bonne fin de soirée.
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Copier avec mise en forme conditionnelle

Bonjour sr94, le forum,

J'ai essayé de comprendre, sans succès, pourquoi l'instruction de copie prend autant de temps.

En fait je pense que votre fichier du post #2 est passablement vérolé.

En effet sur un document vierge j'ai recopié uniquement le tableau et la macro.

Alors l'instruction de copie s'exécute en 0,4 seconde et sur un tableau de 6000 lignes en 3 secondes.

C'est beaucoup plus acceptable.

Fichier joint.

Bonne journée.
 

Pièces jointes

  • test(1).xlsm
    33.3 KB · Affichages: 51
  • test(1).xlsm
    33.3 KB · Affichages: 66
Vote positif 0 Vote négatif
S

sr94

XLDnaute Occasionnel
Re : Copier avec mise en forme conditionnelle

pourtant justement mon fichier d'origine était beaucoup trop long (1 heure vendredi dernier pour extraire les lignes), le fichier que j'ai envoyé est donc un fichier "neuf", mais je veux bien recommencer encore !
HTML:

Ca ne pourrait pas être du aux formules ?

Je vais recommencer en copiant mes 6000 lignes sur un nouveau fichier
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Copier avec mise en forme conditionnelle

sr94 à dit:
Ca ne pourrait pas être du aux formules ?
Cliquez pour agrandir...

Non, comme je l'ai dit j'ai testé :

- en supprimant les formules (par copier/collage spécial-valeurs)

- en supprimant les MFC

- en effaçant la mise en forme

- en convertissant le tableau en plage.

Cela ne changeait pas grand-chose au temps de 4 secondes que j'ai mentionné.

A+
 
Vote positif 0 Vote négatif
S

sr94

XLDnaute Occasionnel
Re : Copier avec mise en forme conditionnelle

J'ai recopié mes 6000 lignes du fichier original dans votre fichier, il a fallu quelques secondes (je dirai une dizaine) avant que le premier fichier soit généré.

Pour la génération des fichiers j'en suis à 8 minutes pour environ un tiers des lignes.

edit : 19 minutes pour la totalité
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Copier avec mise en forme conditionnelle

Re,

La durée totale d'exécution est bien sûr proportionnelle au nombre de fichiers créés.

Chez moi sur un fichier de 6000 lignes certainement plus simple que le vôtre (j'ai simplement copié le tableau de 6 lignes) la durée de création d'un seul fichier est de 5 à 6 secondes, mais les fichiers créés n'ont bien sûr que quelques lignes.

A+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Copier avec mise en forme conditionnelle

Re,

A mon avis on ne peut pas faire mieux car :

- on ne peut pas éviter les opérations de copier-coller, restitution du tableau, mise en forme dans la feuille, enregistrement qui prennent la plus grande partie du temps

- le traitement des données par tableaux VBA pour extraire les lignes sans doublon est ce qu'il y a de plus rapide.

A+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Copier avec mise en forme conditionnelle

Re,

Cette macro est de structure plus logique et fait gagner environ 20% sur la durée d'exécution :

Code: 
Sub Production_Schedule()
Dim F As Worksheet, chemin$, t, tf, ncol%, d As Object, i&
Dim e, critere$, n&, txt$, j%
ThisWorkbook.Save 'enregistrement, à retirer si toujours inutile
Set F = Feuil1 'CodeName de la feuille
chemin = ThisWorkbook.Path & "\" 'à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier existe déjà
F.ListObjects(1).Range.Columns("AG:AH").Delete
F.ListObjects(1).Range.Columns("A:C").Delete
'---supprime (provisoirement) les formules en Col4 et initialise---
With F.ListObjects(1).DataBodyRange
  .Columns(1) = .Columns(1).Value
  t = .Value 'matrice des valeurs
  tf = .FormulaR1C1 'matrice des formules
  ncol = UBound(t, 2)
End With
'---liste des partenaires sans doublon---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 1 To UBound(t)
  If t(i, 5) <> "" Then d(t(i, 5)) = ""
Next i
If d.Count = 0 Then GoTo 1
'---création des fichiers---
For Each e In d.keys
  critere = UCase(e) 'majuscules
  t = F.ListObjects(1).DataBodyRange 'réinitialise
  d.RemoveAll 'RAZ
  n = 0
  For i = 1 To UBound(t)
    If UCase(t(i, 5)) = critere Then
      txt = ""
      For j = 1 To ncol
        txt = txt & Chr(1) & CStr(t(i, j))
      Next j
      If Not d.exists(txt) Then 'pour éliminer les lignes doublons
        d(txt) = ""
        n = n + 1
        For j = 1 To ncol
          t(n, j) = tf(i, j)
        Next j
        t(n, 5) = critere 'facultatif, nom du partenaire en majuscules
      End If
    End If
  Next i
  With Workbooks.Add.Sheets(1) 'nouveau document
    F.ListObjects(1).Range.Copy .[A1]
    .[A1].Copy .[A1] 'vide la mémoire
    With .ListObjects(1).DataBodyRange
      If n Then .Resize(n).FormulaR1C1 = t 'restitution
      If n < .Rows.Count Then .Rows(n + 1 & ":" & .Rows.Count).Delete
    End With
    .Columns.AutoFit 'ajustement de la largeur
    .Columns("C:D").Hidden = True
    critere = Replace(Replace(Replace(Replace(Replace(critere, "/", "_"), "&", "_"), "...", "_"), ".", "_"), " ", "_")
    critere = chemin & "fichier_partenaire_" & critere & "_" & Format(Date, "d-mm-yy")
    .Parent.SaveAs critere, FileFormat:=51 'fichier .xlsx
    .Parent.Close
  End With
Next e
'---rouvre le fichier pour restituer les formules en colonne D---
1 Workbooks.Open ThisWorkbook.FullName
End Sub
Fichier (2).

A+
 

Pièces jointes

  • test(2).xlsm
    33.1 KB · Affichages: 43
  • test(2).xlsm
    33.1 KB · Affichages: 59
Vote positif 0 Vote négatif

Discussions similaires

A
  • Question
XL 2021 Mise en forme conditionnelle
Réponses
2
Affichages
130
Franc58
F
L
  • Résolu(e)
XL 2016 mise en forme conditionnelle
Réponses
2
Affichages
269
litchoutsou
L
P
  • Résolu(e)
Microsoft 365 mise en forme conditionnelle complexe
Réponses
3
Affichages
255
pouetpouetlagalette
P
R
  • Question
XL 2019 Mise en forme conditionnelle
Réponses
4
Affichages
223
Nain porte quoi
N
jeanmi
  • Résolu(e)
XL 2010 utilisation mise en forme conditionnelle
2
Réponses
15
Affichages
507
jeanmi
jeanmi
M
  • Question
Microsoft 365 Copier / coller avec mise en forme VBA
Réponses
0
Affichages
173
marie3107
M
I
  • Résolu(e)
XL 2013 Mise en forme conditionnelle avec formule
Réponses
4
Affichages
383
sylvanu
sylvanu
A
  • Question
Microsoft 365 Modification de mise en forme conditionnelle
Réponses
2
Affichages
246
Anne13
A
M
  • Question
XL 2021 Mise en Forme Conditionnelle avec Formule Complexe
Réponses
4
Affichages
226
sylvanu
sylvanu
A
  • Question
XL 2019 Mise en forme conditionnelle à partir d'un tableau risque
Réponses
14
Affichages
403
JHA
J

Membres actuellement en ligne

8 membres et 94 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 336
Messages
2 087 387
Membres
103 534
dernier inscrit
Kalamymustapha