XL 2013 Copier avec mise en forme conditionnelle

sr94 · 15 Janvier 2016

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

sr94 · 15 Janvier 2016

Re : Copier avec mise en forme conditionnelle

Voilà un fichier exemple j'ai réussi à réduire sa taille.

Il s'agit donc du module 5, j'aimerais que la copie des données prenne en compte les formules et les mises en forme conditionnelles et non seulement les données et le format.

sr94 · 15 Janvier 2016

Re : Copier avec mise en forme conditionnelle

J'ai essayé de rajouter le code suivant mais il y a une erreur (la méthode PasteSpecial de la classe Range a échoué)

Code:

Data.Copy
Application.CutCopyMode = False
Range("tab_Production_Schedule").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

A moins qu'on ne puisse l'intégrer au code déjà existant

job75 · 15 Janvier 2016

Re : Copier avec mise en forme conditionnelle

Bonjour sr94,

Le filtre avancé ne permet pas de copier les formules, donc utiliser cette macro :

Code:

Sub Production_Schedule()
Dim F As Worksheet, critere$, t, tf, ncol%, d As Object, i&, txt$, j%, n&
Set F = Feuil1 'CodeName de la feuille
critere = LCase(F.[AJ5])
Application.ScreenUpdating = False
With Sheets.Add
  F.ListObjects(1).Range.Copy .[A1] 'copie du tableau
  .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)
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = vbTextCompare 'la casse est ignorée
    For i = 1 To UBound(t)
      If LCase(t(i, 5)) = critere Then
        txt = ""
        For j = 1 To ncol
          txt = txt & Chr(1) & 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
        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
End With
End Sub

Même sur une grande base de données c'est rapide car on utilise des tableaux VBA.

[Edit] Remarques : vos MFC dans la feuille "Production_Schedule" sont bien étranges...

A+

sr94 · 15 Janvier 2016

Re : Copier avec mise en forme conditionnelle

Quand je remplace mon code par le tien c'est impeccable, par contre si ensuite je change des valeurs de la colonne 8 (les fichiers sont créés selon cette valeur, 1 fichier par valeur, ce sont des partenaires en fait, et on leur envoie toutes les semaines leur fichier), là je n'ai plus rien quand je relance la macro.

job75 · 15 Janvier 2016

Re : Copier avec mise en forme conditionnelle

Re,

La colonne 8 contient les valeurs à filtrer suivant le critère en AJ5, que voulez-vous de plus ?

J'ai modifié la macro pour que la casse soit ignorée sur ce critère.

A+

sr94 · 15 Janvier 2016

Re : Copier avec mise en forme conditionnelle

mon fichier d'origine contient 6000 lignes, avec en colonne 8 qui est en réalité la colonne "partenaires" les noms des partenaires.

La finalité de cette macro est de créer 1 classeur par partenaire de façon hebdomadaire.

La colonne AJ récupère donc dans la plage les noms de tous les partenaires.

sr94 · 15 Janvier 2016

Re : Copier avec mise en forme conditionnelle

Précision : la macro récupère uniquement la plage concernée, pas tout le classeur

job75 · 15 Janvier 2016

Re : Copier avec mise en forme conditionnelle

Re,

Votre macro ne montrait pas du tout qu'il fallait créer des fichiers !

Et la colonne AJ ne sert à rien, il suffit de créer une liste des "partenaires" :

Code:

Sub Production_Schedule()
Dim F As Worksheet, t, d As Object, i&, liste, e, critere$, tf, ncol%, n&, txt$, j%
Set F = Feuil1 'CodeName de la feuille
'---liste des partenaires sans doublon---
t = F.ListObjects(1).DataBodyRange 'matrice
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à
For Each e In liste
  critere = LCase(e)
  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 LCase(t(i, 5)) = critere Then
          txt = ""
          For j = 1 To ncol
            txt = txt & Chr(1) & 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
          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
    .Parent.SaveAs ThisWorkbook.Path & "\" & critere & ".xlsx", FileFormat:=51
    .Parent.Close
  End With
Next e
End Sub

A+

sr94 · 15 Janvier 2016

Re : Copier avec mise en forme conditionnelle

Bonsoir

J'ai fait l'essai sur mon classeur test, et ça a l'air bien. Merci beaucoup !

Je suis très novice en vba, peux tu me confirmer que pour changer la colonne je remplace le 8 par le numéro de la colonne ? (1 pour A par exemple).

Le fichier prend le nom du partenaire avec la date du jour la macro d'origine comprenait donc le code suivant, le tien gère apparemment bien les caractères spéciaux.

Code:

Range("AI5") = c
[...]
nf = Replace(Replace(Replace(Replace(Replace(c, "/", "_"), "&", "_"), "...", "_"), ".", "_"), " ", "_")
[...]
C:\chemin de fichier\" & "fichier_partenaire_" & nf & "_" & Format(Date, "d-mm-yy")

Le nom du partenaire doit aussi être en majuscule et les colonnes "autofit" avec les colonnes C et D en "hidden".

Enfin dernier élément que tu ne pouvais pas savoir, c'est que dans les fichiers générés les en têtes de certaines colonnes sont modifiées pour être en anglais.

Que dois je modifier pour arriver au même résultat ?

Je crois n'avoir rien oublié ...

Merci encore !

Modification du message : après essai sur mon vrai fichier de 6000 lignes j'ai une erreur 1004 (Microsoft Excel ne peut pas accéder au fichier...) et je ne peux pas continuer. Le nom de ce partenaire contient un / (je ne peux pas modifier les noms qui viennent d'une base ERP)

job75 · 16 Janvier 2016

Re : Copier avec mise en forme conditionnelle

Re,

Le slash / est un des caractères interdits dans les noms des fichiers.

Rien d'autre à faire que de le supprimer en colonne 8.

A+

sr94 · 16 Janvier 2016

Re : Copier avec mise en forme conditionnelle

OK, j'ai rajouté une ligne dans la macro qui me permet de rajouter et supprimer les lignes en provenance de l'ERP (via access), qui va remplacer dans la colonne les / par des _

Pour les majuscules, j'ai vu dans la macro que tu mets "ne tient pas compte de la casse", que dois je modifier pour que tous les noms des partenaires soient en majuscules ?

J'ai vu aussi les delete j'image que j'ai juste à faire le même avec hidden si je veux masquer des lignes.

Dans le nom du fichier j'ai rajouté la date

Pour les en têtes en anglais je vais résoudre le problème autrement, en les mettant en anglais dans le fichier d'origine.

Merci !

job75 · 16 Janvier 2016

Re : Copier avec mise en forme conditionnelle

Bonjour sr94, le forum,

Dans cette macro j'ai tenu compte de votre post #10 :

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
'---liste des partenaires sans doublon---
t = F.ListObjects(1).DataBodyRange 'matrice
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) & 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
End Sub

Adaptez chemin si vous voulez autre chose que ThisWorkbook.Path & "\"

A+

sr94 · 16 Janvier 2016

Re : Copier avec mise en forme conditionnelle

C'est top ça marche impeccable

Dernier petit soucis qui j'espère est le dernier, en colonne A j'ai une formule qui est une RECHERCHEV, j'aurai besoin que la macro me copie le résultat de la recherche puisque la source de cette RECHERCHEV n'existe pas (et ne peut pas exister) dans ce fichier.

J'ai une erreur à l'ouverture du fichier qui me dit que les liaisons ne sont pas bonnes, je pense que c'est du à cette formule.

Merci beaucoup !

Edit : j'ai posté trop vite, j'ai une erreur de incompatibilité de type sur le ligne

Code:

txt = txt & Chr(1) & t(i, j)

quand c'est celui avec le /

job75 · 16 Janvier 2016

Re : Copier avec mise en forme conditionnelle

Re,

sr94 à dit:
Edit : j'ai posté trop vite, j'ai une erreur de incompatibilité de type sur le ligne

txt = txt & Chr(1) & t(i, j)

quand c'est celui avec le /

Ma macro du post #13 ne pose aucun problème dans ce cas, sauf si vous l'avez bricolée.

A+

Effectuez une recherche sur Excel Downloads...

XL 2013 Copier avec mise en forme conditionnelle

sr94

XLDnaute Occasionnel

sr94

XLDnaute Occasionnel

Pièces jointes

sr94

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

sr94

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

sr94

XLDnaute Occasionnel

sr94

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

sr94

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

sr94

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

sr94

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums