XL 2010 [Résolu] Copier onglet dans un nouveau classeur puis trier

leakim

XLDnaute Occasionnel
Bonjour,
J'ai besoin d'aide pour une macro.
J'ai un classeur dans lequel j'ai des groupes qui sont créés. Une fois la création faite, il y a souvent des changements. Ce qui provoque des lignes vides ou des inversions alphabétiques des groupes d'origine. Pour ne pas devoir tout reprendre chaque semaine, j'aimerai pouvoir depuis ma base évolutive créer un classeur qui serait sans lien (donc une copie que des valeurs) et qui serait trié depuis l'ordre alphabétique du nom du groupe initiale.

Comme une image vaut mille mots, je joins deux fichiers, le premier qui est une résultante de mon fichier de base et le second qui est le résultat attendu.
En espérant être clair sur ma requête.

Merci d'avance,
Leakim
 

Pièces jointes

  • PLANNING Forum.xlsm
    133.8 KB · Affichages: 41
  • PLANNING Forum - resultat attendu.xlsm
    41.8 KB · Affichages: 40

ROGER2327

XLDnaute Barbatruc
Bonjour leakim.

On ne devrait pas être trop loin du compte avec quelque chose de ce genre :​
VB:
Sub CopiePropre()
Dim i&, j&, x(), p As Range
'
  Application.ScreenUpdating = False
  x = Array(Array("E7", 16), Array("E27", 21), Array("E53", 16), Array("E73", 16), Array("E93", 16), Array("E113", 16), Array("E133", 16), Array("E153", 16), Array("E173", 16), Array("E193", 16))
  With Sheets("Planning d'activités recto A3"): .Copy After:=Sheets(.Name): End With
  With ActiveSheet
    On Error Resume Next: .Shapes("Picture 1").Delete: On Error GoTo 0
    .UsedRange.Value = .UsedRange.Value
    For i = 0 To UBound(x): For j = 0 To 14 Step 2
        Set p = .Range(x(i)(0)).Resize(x(i)(1), 2).Offset(, j)
        With .Sort
          With .SortFields
            .Clear
            .Add Key:=p.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=p.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
          End With
          .SetRange p
          .Header = xlNo
          .MatchCase = False
          .Orientation = xlTopToBottom
          .SortMethod = xlPinYin
          .Apply
        End With
    Next j, i
    .Move
  End With
End Sub

(Remplacer .txt par .bas avant d'importer la pièce jointe dans votre classeur.)​

Bonne journée.


ℝOGER2327
#8296


Dimanche 1[SUP]er[/SUP] Tatane 143 (Fête du Père Ubu (Ubu d’été) - fête Suprême Première seconde)
26 Messidor An CCXXIV, 0,3268h - sauge
2016-W28-4T00:47:03Z
 

Pièces jointes

  • Copier.txt
    1.2 KB · Affichages: 37
Dernière édition:

leakim

XLDnaute Occasionnel
Bonjour ROGER2327,
Je te remercie pour ta macro, c'est fonctionnel !!!
Au bénéfice du rangement il y a trop de ligne sur le doc final. Serait-il possible d'avoir cinq lignes en moins sur chaque zone de façon automatique?
Pour le nom du classeur créé, serait-il possible que le nom soit "planning"& E1&" | "&texte(maintenant();"dd/mm/aaaa hh:mm")
Ultime critère, sur les semaines paires j'ai des demi groupe qui sont reconnaissables grâce à l'indicatif 0.5 qui vient à la fin de tous les noms. Dans ce cas, il serait souhaitable que le tri ne s'applique pas.

Merci pour ta proposition.
Cordialement,

Leakim
 
Dernière édition:

ROGER2327

XLDnaute Barbatruc
Re...

Bonjour ROGER2327,
Je te remercie pour ta macro, c'est fonctionnel !!!
(...)
Bonjour. Tant mieux !​

(...)
Au bénéfice du rangement il y a trop de ligne sur le doc final. Serait-il possible d'avoir cinq lignes en moins sur chaque zone de façon automatique?
(...)
Oui ! On peut même faire mieux en n'affichant que le minimum de lignes nécessaires.

Si vous préférez masquer systématiquement cinq lignes (attention à la possible perte d'informations !), il vous suffira de
  • supprimer les lignes de code suivantes :
Code:
  m = 1
'...
  For k = x(i)(1) To 1 Step -1
  If p.Cells(k, 1) & p.Cells(k, 2) <> "" Then Exit For
  Next
  If k > m Then m = k
'...
  • remplacer cette ligne :
Code:
  .Resize(x(i)(1) - m - (x(i)(1) = m)).Offset(m).EntireRow.Hidden = True
par celle-ci :​
Code:
  .Resize(5).Offset(x(i)(1) - 5).EntireRow.Hidden = True
  • supprimer la déclaration de la variable m& désormais inutile.
(...)
Pour le nom du classeur créé, serait-il possible que le nom soit "planning"& E1&" | "&texte(maintenant();"dd/mm/aaaa hh:mm")
(...)
Non ! C'est truffé de caractères interdits dans un nom de fichier.
Dans le classeur joint, j'ai laissé l'intitulé que vous proposez : vous verrez que la bête se fâche.
Pour la calmer, il vous faudra modifier la ligne :​
Code:
  u = "planning" & [E1].Value & " | " & Format(Now(), "dd/mm/yyyy hh:mm") 'Incorrect
en la remplaçant, par exemple, par celle-ci :​
Code:
  u = "Planning S" & Trim(Right$([E1].Value, 2)) & "-" & Format(Now(), "yyyymmdd-hhmmss") 'Correct
Remarque : le classeur maître doit préalablement avoir été enregistré dans un dossier autorisé en écriture. Le nouveau classeur est enregistré dans ce même dossier. Pour enregistrer ailleurs, il faut modifier la variable Chemin.​


(...)
Ultime critère, sur les semaines paires j'ai des demi groupe qui sont reconnaissables grâce à l'indicatif 0.5 qui vient à la fin de tous les noms. Dans ce cas, il serait souhaitable que le tri ne s'applique pas.
(...)
Je pas comprendre.​

Bonne nuit.

Code:
Sub CopiePropre()
Dim i&, j&, k&, m&, u$, s$(1), x() As Variant, p As Range, Chemin$
  Application.ScreenUpdating = False
  Chemin = ThisWorkbook.Path & "\"
  x = Array(Array("E7", 16), Array("E27", 21), Array("E53", 16), Array("E73", 16), Array("E93", 16), Array("E113", 16), Array("E133", 16), Array("E153", 16), Array("E173", 16), Array("E193", 16))
  With Sheets("Planning d'activités recto A3"): .Copy After:=Sheets(.Name): End With
  With ActiveSheet
  On Error Resume Next: .Shapes("Picture 1").Delete: On Error GoTo 0
  .UsedRange.Value = .UsedRange.Value
  For i = UBound(x) To 0 Step -1
  m = 1
  With .Range(x(i)(0))
  For j = 0 To 14 Step 2
  Set p = .Resize(x(i)(1), 2).Offset(, j)
  With .Parent.Sort
  With .SortFields
  .Clear
  .Add Key:=p.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  .Add Key:=p.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  End With
  .SetRange p
  .Header = xlNo: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin
  .Apply
  End With
  For k = x(i)(1) To 1 Step -1
  If p.Cells(k, 1) & p.Cells(k, 2) <> "" Then Exit For
  Next
  If k > m Then m = k
  Next
  .Resize(x(i)(1) - m - (x(i)(1) = m)).Offset(m).EntireRow.Hidden = True
  End With
  Next
  On Error GoTo ErrNom1
'  u = "planning" & [E1].Value & " | " & Format(Now(), "dd/mm/yyyy hh:mm:ss") 'Incorrect
  u = "Planning " & Trim(Right$([E1].Value, 2)) & " | " & Format(Now(), "dd-mm-yyyy hhmmss") 'Correct
  .Name = u: .Move
  End With
  u = "planning" & [E1].Value & " | " & Format(Now(), "dd/mm/yyyy hh:mm") 'Incorrect
'  u = "Planning S" & Trim(Right$([E1].Value, 2)) & "-" & Format(Now(), "yyyymmdd-hhmmss") 'Correct
  On Error GoTo ErrNom2
  ActiveWorkbook.SaveAs Filename:=Chemin & u
Exit Sub
ErrNom1: s(0) = "cet onglet": s(1) = "L'onglet n'est pas renommé.": GoTo ErrNom
ErrNom2: s(0) = "ce classeur": s(1) = "Le classeur n'est pas enregistré."
ErrNom:
  u = InputBox(u & vbLf & "n'est pas un nom admissible pour " & s(0) & "." & vbLf & "Modifiez-le ou donnez-en un autre :", , u)
  If u = "" Then MsgBox s(1), vbCritical: Resume Next Else Resume
End Sub


ℝOGER2327
#8297


Lundi 2 Tatane 143 (Commémoration du Père Ebé - fête Suprême Quarte)
27 Messidor An CCXXIV, 0,1690h - ail
2016-W28-5T00:24:21Z
 

Pièces jointes

  • Copie de PLANNING Forum-1.xlsm
    149.8 KB · Affichages: 33
Dernière édition:

leakim

XLDnaute Occasionnel
Bonjour,
Merci pour ces compléments. J'ai modifié le code de sorte à pouvoir masquer les lignes. D'ailleurs le fait le masquer plutôt que supprimer est une très bonne précaution ! J'ai pas bien compris le commentaire ?
Oui ! On peut même faire mieux en n'affichant que le minimum de lignes nécessaires.
qu'est ce que tu entends par là ?

Pour la dénomination du fichier c'est presque nickel. J'ai un message lors de la fin de copie qui me demande systématiquement quelle extension je valide : avec ou sans prise en charge de macro ? Je pense qu'il serait nécessaire d'ajouter l'extension .xls (sans macro) au nom de sorte qu'il n'y est plus cette question.
Pour la remarque sur le chemin je pense que je vais resté sur le même répertoire, au plus simple.

Pour finir sur l'incompréhension. Dans le fichier initiale lors de la semaine impaire les lundis après midi dans le groupe marche, il y a un indicatif 0.5 à la fin de chaque nom. Cela est fait pour indiquer qu'il y a deux groupes de marche distincts.
De fait, il est souhaitable que le tri ne s'effectue pas sur cette zone en raison. Lorsque le tri est fait, et je t'en remercie encore, cela réorganise l'affichage sauf que le cas échéant il n'est pas nécessaire de modifier la constitution des deux sous groupe, sinon je n'ai plus qu'un seul grand groupe.
En espérant être clair cette fois-ci dans ma requête.

Cordialement,
Leakim
 

ROGER2327

XLDnaute Barbatruc
Re...

Avant d'aller plus loin, j'aimerais que vous confirmassiez ou infirmassiez ce résultat :​

capture-jpg.969068
Si vous confirmez, c'est que j'ai écrit un code correct en n'ayant rien compris du problème.
Si vous infirmez, le code est bon pour la poubelle...​


Bonne nuit.


ℝOGER2327
#8298


Lundi 2 Tatane 143 (Commémoration du Père Ebé - fête Suprême Quarte)
27 Messidor An CCXXIV, 9,4244h - ail
2016-W28-5T22:37:06Z
 

Pièces jointes

  • Capture.JPG
    Capture.JPG
    58.7 KB · Affichages: 142

leakim

XLDnaute Occasionnel
Bonjour,
Je confirme que le code est fonctionnel et je pense que tu as bien compris. L'erreur vient d'un bug d'affichage généré par la MFC.
Si j'ôte la MFC de cette zone, la liste devient

APPART GUI Del
BAYARD LAP Phi
DUGU. CES Jes
DUGU. LEG Ren
DUGU. RAB Guy
DUGU. VEN Béa
EXT. BOU Gwl
EXT. BRE Cin

BAYARD LAR Ann
EXT. BEL Laë
EXT. HAC Lin
LANCELOT GRA Gér

Ton commentaire me permet d'améliorer la formule de la MFC et je t'en remercie !
La MFC =OU(NB.SI(E$27:E27;E27)=1;E26="") devient =OU(NB.SI(E$27:E27;E27)=1;E26<>E27) ce qui donne:

APPART GUI Del
BAYARD LAP Phi
DUGU. CES Jes
DUGU. LEG Ren
DUGU. RAB Guy
DUGU. VEN Béa
EXT. BOU Gwl
EXT. BRE Cin

BAYARD LAR Ann
EXT. BEL Laë
EXT. HAC Lin
LANCELOT GRA Gér


Cordialement,
Leakim
 

ROGER2327

XLDnaute Barbatruc
Re...

Bonjour,
Je confirme que le code est fonctionnel et je pense que tu as bien compris. L'erreur vient d'un bug d'affichage généré par la MFC.
(...)
Me voilà rassuré. Essayez le code mis en pièce jointe.
J'espère avoir traité correctement cette histoire de suffixe "0.5" que je ne vois nulle part...
Dites-moi ce que vous en pensez.

Quant à la question sur «l'affichage d'un minimum de lignes», j'entends par là que je ne supprime pas systématiquement cinq lignes, mais que j'en supprime autant qu'il est possible sans perdre de données : ce peut être plus ou moins de cinq selon le nombre de lignes non vides.​

Bonne journée.

ℝOGER2327
#8300


Mardi 3 Tatane 143 (Sainte Crapule, puriste et Saint Fantomas, archange - fête Suprême Quarte)
28 Messidor An CCXXIV, 5,1552h - vesce
2016-W28-6T12:22:20Z

(Remplacer .txt par .bas avant d'importer la pièce jointe dans votre classeur.)
 

Pièces jointes

  • Copier.txt
    3.1 KB · Affichages: 39
Dernière édition:

leakim

XLDnaute Occasionnel
Bonjour,
Je te remercie pour cette adaptation de la macro. Le résultat n'est pas probant cette fois. Je me demande si la piste de faire un test ne serait pas plus modulable? Si le contenu est texte alors on tri sinon on tri pas, plutôt que de chercher un caractère ou une fin de mot 0.5?
Je veux bien voir ce que cela donne ta proposition de ne garder que le nombre de ligne nécessaire plutot que supprimer 5 lignes.

Cordialement,
Leakim
 

leakim

XLDnaute Occasionnel
Re,
Je viens de prendre un café... et mon message précédent ne tient pas compte que nous somme sur une chaîne de caractère plutôt que sur un contenu de cellule. Le contenu est de fait, texte, même si dans la chaîne de caractère, il y a des caractères numériques, n'est ce pas ? Alors je pense qu'il faut peut-être rester sur le test de fin mot qui se termine par 5 ou pas. A moins, de faire un test sur la chaine de caractère et rechercher si celle-ci contient un ou des caractères numériques. Mais là, cela devient de la science fiction pour moi de traduire cela en macro.
En espérant ne pas t'avoir trop embrouiller avec mes commentaires.
J'espère que tu es plus inspiré que moi.

Cordialement,
Leakim
 
Dernière édition:

ROGER2327

XLDnaute Barbatruc
Re...

y-a-t-il ce fameux "0.5" ? Fournissez un exemple avant et après traitement car j'ai l'impression de ne pas travailler sur le même classeur que vous.​

Bonne journée.

ℝOGER2327
#8302


Mercredi 4 Tatane 143 (Ascension du Mouchard, statisticien, psychiatre et policier - fête Suprême Quarte)
29 Messidor An CCXXIV, 3,4702h - blé
2016-W28-7T08:19:43Z
 

leakim

XLDnaute Occasionnel
Bonjour,
J'ai mis à jour le fichier comme mon doc d'origine. j’espère que cela sera plus parlant.
Cordialement,
Leakim
 

Pièces jointes

  • Planning S29-20160717-114521.xlsx
    40.4 KB · Affichages: 31
  • PLANNING ForumV2.xlsm
    139.6 KB · Affichages: 34

ROGER2327

XLDnaute Barbatruc
Re...

À essayer...

Bonne journée.

ℝOGER2327
#8303


Jeudi 5 Tatane 143 (Saint Arsouille, patricien - fête Suprême Quarte)
30 Messidor An CCXXIV, 1,0721h - chalémie
2016-W29-1T02:34:23Z
 

Pièces jointes

  • PLANNING ForumV2.xlsm
    137.7 KB · Affichages: 33

leakim

XLDnaute Occasionnel
Bonjour,
C'est vraiment super! Bravo et merci !
Au bénéfice de la remise en forme par la macro, je gagne beaucoup de place. Est ce possible de grossir le résultat final.
J'aimerai si c'est possible que les lignes puissent avoir une hauteur de 18 pixel et que le contenu soit de taille 14.

Merci encore pour cette macro qui va me faire gagner un temps précieux.
Cordialement,
Leakim
 

ROGER2327

XLDnaute Barbatruc
Re...

Tout (ou presque tout) est possible.
Essayez en ajoutant cette ligne :​
Code:
  With .Resize(n, j): .EntireRow.AutoFit: .Font.Size = 14: End With
avant celle-ci :​
Code:
  .Resize(n - m).Offset(m).EntireRow.Hidden = 1
Mais le plus simple est encore de définir les hauteurs, largeurs, alignements, fontes, etc. sur l'onglet Planning d'activités recto A3. Comme la procédure travaille sur une copie de cet onglet, tous vos formatages seront conservés.​


ℝOGER2327
#8305


Jeudi 5 Tatane 143 (Saint Arsouille, patricien - fête Suprême Quarte)
30 Messidor An CCXXIV, 5,2485h - chalémie
2016-W29-1T12:35:47Z
 

Discussions similaires