[VBA] Besoin d'aide pour la création d'une macro [Résolu]

villette54

XLDnaute Junior
Re : [VBA] Besoin d'aide pour la création d'une macro

Bonjour !

L'ajout de ce calendrier n'était qu'un gadget sur mon document.
Si c'était relativement "simple", je l'aurais ajouté mais là je ne pense pas que le calendrier que tu proposes Chalet soit adapté (plusieurs personnes vont utiliser le fichier, dont certaines qui ne touche à un PC que pour le remplir)
Quant à ton idée Tirou (les 3 listes déroulantes), elle est plus envisageable mais bon il va falloir que j'ajoute x colonnes et que je m'amuse à refusionner tout ce qui doit l'être sur toute la hauteur du formulaire, pour au final un intérêt assez limité.

Autre chose qui pourrait m'être plus utile, est-il possible que la hauteur d'une cellule fusionnée s'ajuste automatiquement en fonction de la longueur texte à l'intérieur ? (Si ne je suis pas clair, je mettrais un fichier en exemple)
 
Dernière édition:

CHALET53

XLDnaute Barbatruc
Re : [VBA] Besoin d'aide pour la création d'une macro

Bonjour,

Essai ce code de Job75

Sub AjusteEnHauteur()
For Each cel In ActiveSheet.UsedRange
If cel <> "" Then
Set m = cel.MergeArea
m.UnMerge
m.WrapText = True 'renvoie à la ligne
m.HorizontalAlignment = xlCenterAcrossSelection
m.Rows.AutoFit
m.Merge
m.HorizontalAlignment = xlGeneral 'facultatif bien sûr
End If
Next
End Sub

a+
 

villette54

XLDnaute Junior
Re : [VBA] Besoin d'aide pour la création d'une macro

Merci mais...
J'ai fais un essai mais ce n'était pas très concluant (ça m'a massacré toute la mise en page)
Sais-tu comment je peux faire pour qu'il ne s'applique qu'à quelques cellules de mon document ?
 

villette54

XLDnaute Junior
Re : [VBA] Besoin d'aide pour la création d'une macro

Re,

J'ai des cellules fusionnées en "ligne" de B27 à F27 par exemple.
Dans ces cellules les utilisateurs peuvent être amenés à taper 2 mots, ou un roman.
Du coup j'aimerais que la hauteur de la ligne s'ajuste automatiquement en fonction de la quantité de texte.

J'ai beau utilisé la macro que tu proposes et l'adapter, la taille de la cellule ne se modifie pas.
 

Si...

XLDnaute Barbatruc
Re : [VBA] Besoin d'aide pour la création d'une macro

salut

j'avais commencé à chercher (d'une façon totalement différente).
Je viens de rajouter un calendrier sommaire.
Attention, la saisie des nouveautés, par formulaire, n'est pas contrôlée.
On peut encore y rajouter les corrections de données.
 

Fichiers joints

Tirou

XLDnaute Occasionnel
Re : [VBA] Besoin d'aide pour la création d'une macro

Un essai pour le choix de la date par multi liste déroulantes.

La case cachée en dessous prend en compte la date au format 01/02/2012 pour la compatibilité avec d'éventuelles macros. (la couleur du texte est blanc sur blanc pour la cacher)

Par contre, une fois fini, je me rends compte d'un bug : l'activation de la macro suite au changement dans la feuille fait passer le mois en anglais ... alors là, je n'ai aucune idée de comment résoudre le problème.

Autre problème connu : on peut entrer la date du 31 février ... Corrigeable dans un second temps, mais d'abords est-ce que cette solution de parait viable pour ton application?
 

Fichiers joints

villette54

XLDnaute Junior
Re : [VBA] Besoin d'aide pour la création d'une macro

Bonjour à tous,
Et merci pour votre aide.

Chalet, oui j'ai redéfini les zones de la macro. Voici ma macro actuelle :
Code:
       If Not (Intersect(Target, Range("B38,B42,B49,B53,B57,B69,B77,B87")) Is Nothing) Then
             For Each cel In ActiveSheet.UsedRange
            If cel <> "" Then
            Set m = cel.MergeArea
            m.UnMerge
            m.WrapText = True 'renvoie à la ligne
            m.HorizontalAlignment = xlCenterAcrossSelection
            m.Rows.AutoFit
            m.Merge
            m.HorizontalAlignment = xlGeneral 'facultatif bien sûr
            End If
            Next
        End If

End Sub
Effectivement, la macro fonctionne lorsque j'écris dans une de ces cellules, mais à coté de ça elle me modifie/supprime la mise en page de toute les autres cellules fusionnées du formulaire.
J'ai essayer avec ou sans le code dans le module 1 (celui là je l'ai gardé tel quel) mais rien n'y fais. Toutes mes hauteurs de cellules sont modifiées, et non pas seulement celle dans laquelle j'écris.

'---------------------------------------

Si..., je n'arrive pas à utiliser ton USF. Dès que je clique sur date ou sujet j'ai ceci qui se met en erreur (ce qui est avancé) :
Code:
                            Private Sub L1_Click()
  Me.Height = 100
  B = 0
  C1.Clear: L2.Clear
  n = L1.ListIndex
                                Td = n = 0
Avec comme message : Can't find project or library.

'---------------------------------------

Tirou, huum effectivement cette solution est envisageable si on met les listes déroulantes de la taille de la cellule. Le fait que le mois soit en anglais n'est pas vraiment un problème. Est-il possible de voir pour un conditionnement de manière à éviter les blagues du genre tous le 31 février.
Autre question, ta solution est-elle transposable rapidement ? Le fichier que j'en envoyé n'est qu'un extrait du formulaire, je dois avoir au total 3 ou 4 cellules qui demandent une date.
 
Dernière édition:

Tirou

XLDnaute Occasionnel
Re : [VBA] Besoin d'aide pour la création d'une macro

Ci-joint un essai avec limitation aux dates valides. Malheureusement, la mise en place des boutons réduit les possibilités par rapport à une validation classique (pas d'accès à la formule DECALER qui aurait carrément retiré de la liste les entrées invalides) ce qui fait qu'on peu faire bugger en cliquant sur les jours "blancs". mais bon, plus de 29 février, sauf pour les années bissextiles.

Mmm, si ton formulaire appelle 3 ou 4 cellules dates différentes, je pense que c'est un mauvais plan. (multiplication des plages nommées, et de pas mal d'autres cellules de fonctionnement). Les dates sont-elles les mêmes ou peuvent-elles être différentes?

Dans le cas de différentes, je pense que l'userform de Si... est déjà une bonne base.




Pour l'ajustement de hauteur, essayes avec
Code:
        If Not (Intersect(Target, Range("B38,B42,B49,B53,B57,B69,B77,B87")) Is Nothing) Then
            Set cel = Target
            On Error GoTo GestionErreur 'Evite le cas de l'utilisation de la touche suppr (fait planter)
            If cel <> "" Then
            Set m = cel.MergeArea
            m.UnMerge
            m.WrapText = True 'renvoie à la ligne
            m.HorizontalAlignment = xlCenterAcrossSelection
            m.Rows.AutoFit
            m.Merge
            m.HorizontalAlignment = xlGeneral 'facultatif bien sûr
            End If
        End If
GestionErreur:
End Sub
 

Fichiers joints

Dernière édition:

villette54

XLDnaute Junior
Re : [VBA] Besoin d'aide pour la création d'une macro

Tirou,

La gestion des dates comme ça est bien. (Mais je ne comprend pas trop comment fonctionne les menus déroulants)
Je ne vais pas compliquer la tâche les 2 autres cases où une date est envisageable sont des dates différentes mais ne seront utilisés que dans 1 cas sur 10 au mieux.

Pour ce qui est de la hauteur de ligne, la modification que tu as apporté au code à résolu mon problème !

Merci !
 

villette54

XLDnaute Junior
Re : [VBA] Besoin d'aide pour la création d'une macro

Huum.

J'ai crié victoire trop vite, pour la hauteur des cellules...
En fait ma cellule B77 par exemple (valable pour toutes les autres) est fusionnée est de B à F. Mais le calcul de la hauteur en fonction du nombre de retour à la ligne ne se fait que sur la largeur de la colonne B et non de la plage B à F. Du coup si on tape un mot ça va, ça s'ajuste bien mais si on commence à taper un texte assez long on a une haute disproportionnée !

J'espère que j'ai été clair, c'est pas facile à expliquer.
 

Tirou

XLDnaute Occasionnel
Re : [VBA] Besoin d'aide pour la création d'une macro

Mmm, il va falloir expliciter, ou donner un fichier exemple, parce que là, je ne comprends pas :s

Avec un mot super long ou un texte long, j'ai la bonne hauteur de ligne ...
 

Si...

XLDnaute Barbatruc
Re : [VBA] Besoin d'aide pour la création d'une macro

salut

pour mon premier fichier, sans doute un problème de références.
Références.jpg

pour le second fichier (totalement différent), j'ai inclus le calendrier du premier et j'ai changé la présentation (lignes cachées ou pas,cellules changées ou pas) avec ce que j'ai compris :confused:.

Comme le dit Tirou ;), une exemple précis est nécessaire Si... on ne veut pas errer de fil en fil.
 

Fichiers joints

villette54

XLDnaute Junior
Re : [VBA] Besoin d'aide pour la création d'une macro

Re,

Tirou, voici une version un peu plus aboutie de mon fichier (désolé si mon code VBA est dégueulasse)
Essaye d'écrire dans toutes les "grandes cellules" (celles fusionnées de B à F) et regarde comment s'ajuste la hauteur.

Si..., je jette un oeil a mes références et je te retiens au courant.


PS : J'ai l'impressions qu'on me fait activer toutes les références/bibliothèques 1 par 1. N'est-il pas plus simple de toutes les cocher une fois pour toute ?

EDIT : mon fichier dépasse la taille maximale autorisée par le forum, voici donc le lien pour le télécharger : http://cjoint.com/?3IkqNeE5A8B
 
Dernière édition:

villette54

XLDnaute Junior
Re : [VBA] Besoin d'aide pour la création d'une macro

Je comprends mieux certains de mes bugs !

Missing.JPG

Ce dossier n'existe même pas sur mon PC (chemin indiqué en dessous)
 

Tirou

XLDnaute Occasionnel
Re : [VBA] Besoin d'aide pour la création d'une macro

Coucou,

Ci-joint une version avec la taille de cellule mieux ajustée. Le problème intervenait lorsque excel refusionnait les cellules (avant la refusion, elles étaient à bonne taille). Solution : stocker dans une variable la hauteur de la cellule et forcer à bonne hauteur après la procédure buggée d'excel.

A te relire

Par ailleurs, la compression des fichiers passe bien pour limiter l'impact sur la mémoire du serveur ;)
 

Fichiers joints

villette54

XLDnaute Junior
Re : [VBA] Besoin d'aide pour la création d'une macro

Salut

Huum. Ok je comprends (comment t'as fais, mais pas pourquoi ça bug)
Je te remercie.

J'ai encore besoin de toi quelques choses si ça ne te dérange pas.
J'aimerais savoir comment définir des options d'impressions mais sans imprimer (juste au cas où, ou alors pour le prochain)
Voici ma macro actuelle :
Code:
Sub Button7_Click()

If MsgBox("Voulez-vous vraiment archiver cet enlèvement ?", vbQuestion + vbYesNo, "Confirmation") = vbYes Then
  'Desactive les changement à l'écran
Application.ScreenUpdating = False

  'Déclaration de variable
Dim archive As String

    'Créer un nouveau worbook
Workbooks.Add
newclass = ActiveWorkbook.Name
    
    'Copie des cellules du classeur d'origine
Windows("Outils Facturation.xlsm").Activate
Sheets("Facture").Select
Cells.Select
Selection.Copy
    
    'Selection nouveau classeur
Windows(newclass).Activate
Sheets(1).Select
    
    'collage valeurs
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    'collage format (pour les dates entre autre)
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
    
    'Chemin d'accès fichier
archive = "U:\...\Archive\" & "Enlèvement " & [G3].Value & " du " & [B1].Value & ".xlsx"
    
        'Copie des cellules du classeur d'origine
Windows("Outils Facturation.xlsm").Activate
Sheets("Encodage").Select
Cells.Select
Selection.Copy
    
    'Selection nouveau classeur
Windows(newclass).Activate
Sheets(2).Select
    
    'collage valeurs
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    'collage format (pour les dates entre autre)
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

    'Hide feuille inutilisée
Sheets("Sheet3").Visible = False
    
    'sauvegarde du nouveau fichier
ActiveWorkbook.SaveAs Filename:=archive, _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
    
    'Retour sur classeur d'origine
Windows("Outils Facturation.xlsm").Activate
Range("A1").Select
    
      'On rétabli ce qu'on a désactivé avant
Application.ScreenUpdating = True

MsgBox "Fichier arichivé à l'adresse suivant : " & vbCrLf & archive

  Else: MsgBox "Echec de l'archivage !"
  End If
  
End Sub
Cette macro extrait 2 feuilles de mon classeur (qui en contient une dizaine) et les copie sur un nouveau classeur en valeur uniquement.
Le soucis c'est que j'aimerais ajouter des options à mes 2 feuilles :
- Marge haut/bas/gauche/droite = 0
- Option d'impression : centrée sur la feuille
- Option d'impression : feet sheet on one page (je sais pas comment ça s'appelle en français, c'est pour que un le zoom s'ajuste automatiquement de manière à tout faire rentrer sur une feuille)
- Nommée la page "encodage" sur le premier fichier "encodage" sur le second aussi (idem facturation)
- Avoir un affichage en "Page Break View" (je sais pas non plus comment ça s'appelle en français mais c'est pour n'avoir que la partie "remplie" de la feuille afficher, le reste se grise)

Ça fait beaucoup désolé ^^' mais c'est tous ce que je n'ai pas réussi à trouver par moi-même.
Si besoin je t'envoie un fichier avec la macro pour que tu visualises mieux.

Merci d'avance.

PS : désolé pour tous les commentaires, c'est pour m'y retrouver.
 
Dernière édition:

Tirou

XLDnaute Occasionnel
Re : [VBA] Besoin d'aide pour la création d'une macro

Voila ta macro avec les rajouts demandés (et légèrement retravaillée).

J'avoue que l'enregistreur de macro est mon ami sur ce coup. Je la retravaille et te fournis une version plus synthétique (y compris pour ce que tu as codé)
Code:
Sub Button7_Click()

    If MsgBox("Voulez-vous vraiment archiver cet enlèvement ?", vbQuestion + vbYesNo, "Confirmation") = vbYes Then
            'Desactive les changement à l'écran
        Application.ScreenUpdating = False
        
            'Déclaration de variable
        Dim archive As String
        
            'Créer un nouveau worbook
        Workbooks.Add
        newclass = ActiveWorkbook.Name
          
            'Copie des cellules du classeur d'origine
        Windows("Outils Facturation.xlsm").Activate
        Sheets("Facture").Cells.Copy
          
            'Selection nouveau classeur
        Windows(newclass).Activate
        With Workbook(newclass).Sheets(1)
            Application.CutCopyMode = False
            .Name = "Facture" 'Nommée la page "encodage" sur le premier fichier "encodage" sur le second aussi (idem facturation)
            .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'collage valeurs
            .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'collage format (pour les dates entre autre)
            End With
                    
          'Chemin d'accès fichier
        archive = "U:\...\Archive\" & "Enlèvement " & [G3].Value & " du " & [B1].Value & ".xlsx"
          
              'Copie des cellules du classeur d'origine
        Windows("Outils Facturation.xlsm").Activate
        Sheets("Encodage").Cells.Copy
          
          'Selection nouveau classeur
        Windows(newclass).Activate
        With Workbook(newclass).Sheets(2)
            Application.CutCopyMode = False
            .Name = "Encodage"
            .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'collage valeurs
            .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'collage format (pour les dates entre autre)
            End With
        
            'Hide feuille inutilisée
        Sheets("Sheet3").Delete 'Sheets("Sheet3").Visible =
        
            'Défini les paramètres d'impression
        ActiveWindow.View = xlPageBreakPreview  'Avoir un affichage en "Page Break View"
        Application.PrintCommunication = False
        For i = 1 To 2 'Boucle sur les 2 pages, vu que c'est la même
            With Workbook(newclass).Sheets(1).PageSetup
                .PrintArea = "$A$1:$G$96" 'A vérifier, j'ai pris le fichier exemple de formulaire.
                .LeftHeader = ""
                .CenterHeader = ""
                .RightHeader = ""
                .LeftFooter = ""
                .CenterFooter = ""
                .RightFooter = ""
                .LeftMargin = Application.InchesToPoints(0) 'Marge haut/bas/gauche/droite = 0
                .RightMargin = Application.InchesToPoints(0)
                .TopMargin = Application.InchesToPoints(0)
                .BottomMargin = Application.InchesToPoints(0)
                .HeaderMargin = Application.InchesToPoints(0.31496062992126)    'A définir si ok
                .FooterMargin = Application.InchesToPoints(0.31496062992126)    'A définir si ok
                .PrintHeadings = False
                .PrintGridlines = False
                .PrintComments = xlPrintNoComments
                .PrintQuality = 600
                .CenterHorizontally = True
                .CenterVertically = True
                .Orientation = xlPortrait
                .Draft = False
                .PaperSize = xlPaperLetter
                .FirstPageNumber = xlAutomatic
                .Order = xlDownThenOver
                .BlackAndWhite = False
                
                .Zoom = False   'Option d'impression : centrée sur la feuille
                .FitToPagesWide = 1
                .FitToPagesTall = 1
                
                .PrintErrors = xlPrintErrorsDisplayed
                .OddAndEvenPagesHeaderFooter = False
                .DifferentFirstPageHeaderFooter = False
                .ScaleWithDocHeaderFooter = True
                .AlignMarginsHeaderFooter = True
                .EvenPage.LeftHeader.Text = ""
                .EvenPage.CenterHeader.Text = ""
                .EvenPage.RightHeader.Text = ""
                .EvenPage.LeftFooter.Text = ""
                .EvenPage.CenterFooter.Text = ""
                .EvenPage.RightFooter.Text = ""
                .FirstPage.LeftHeader.Text = ""
                .FirstPage.CenterHeader.Text = ""
                .FirstPage.RightHeader.Text = ""
                .FirstPage.LeftFooter.Text = ""
                .FirstPage.CenterFooter.Text = ""
                .FirstPage.RightFooter.Text = ""
            End With
        Next i
        
        Application.PrintCommunication = True
          
          'sauvegarde du nouveau fichier
        ActiveWorkbook.SaveAs Filename:=archive, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close
          
          'Retour sur classeur d'origine
        Windows("Outils Facturation.xlsm").Activate
        Range("A1").Select
          
            'On rétabli ce qu'on a désactivé avant
        'Application.ScreenUpdating = True 'Même commentaire qu'avant, ce paramètre est remis automatiquement à True à la fin de tes macros
        
        MsgBox "Fichier arichivé à l'adresse suivant : " & vbCrLf & archive
        
        Else: MsgBox "Echec de l'archivage !"
    End If
End Sub
 

Tirou

XLDnaute Occasionnel
Re : [VBA] Besoin d'aide pour la création d'une macro

Voici une version plus simple qui te permet de copier les feuilles à l'identique (ne copie pas les boutons et autres objets flottants).

Par contre, comme on copie tout, cela copie aussi les validations de données, les macros écrites dans la feuille, les formules, les liens vers les autres feuilles/classeurs etc etc. A voir si c'est problématique pour toi. Auquel cas, dis le moi, je repartirai de ta macro pour l'épurer.

Code:
Sub Button7_Click()
    'Desactive les changement à l'écran
    Application.ScreenUpdating = False
    
    'Déclaration de variable
    Dim archive As String
    
    If MsgBox("Voulez-vous vraiment archiver cet enlèvement ?", vbQuestion + vbYesNo, "Confirmation") = vbYes Then

            'Créer un nouveau worbook
        Set fileTarget = Workbooks.Add
        Set fileSource = Workbooks("Outils Facturation.xlsm")
        
            'Copie la feuille du classeur d'origine
        fileSource.Sheets("Facture").Copy Before:=fileTarget.Sheets(1)
        fileSource.Sheets("Encodage").Copy After:=fileTarget.Sheets(1)

            'Suppression des feuilles inutilisées
        For i = 3 To 5
            Sheets(i).Delete
            Next i
          
          'Chemin d'accès fichier
        archive = "U:\...\Archive\" & "Enlèvement " & fileSource.Sheets("Facture").[G3].Value & " du " & fileSource.Sheets("Facture").[B1].Value & ".xlsx"

          'sauvegarde du nouveau fichier
        fileTarget.SaveAs Filename:=archive, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        fileTarget.Close
          
          'Retour sur classeur d'origine
        fileSource.Range("A1").Select

        MsgBox "Fichier arichivé à l'adresse suivant : " & vbCrLf & archive
        
    Else: MsgBox "Echec de l'archivage !"
    End If
End Sub

'Défini les paramètres d'impression : Ce sont déjà les paramètres d'impression et de présentation des feuilles d'origine
 
Dernière édition:

Discussions similaires


Haut Bas