Amélioration code

Résolu/Fermé

vielhom Messages postés 24 Date d'inscription mercredi 11 novembre 2015 Statut Membre Dernière intervention 30 décembre 2015 - Modifié par baladur13 le 7/12/2015 à 10:56
gbinforme Messages postés 14946 Date d'inscription lundi 18 octobre 2004 Statut Contributeur Dernière intervention 24 juin 2020 - 7 déc. 2015 à 18:06

Bonjour,

Ce code a été effectué avec l'enregistreur de macros.
Peut-il être amélioré ?

Private Sub CommandButton1_Click()
   Columns("B:D").Select
    Selection.Insert Shift:=xlToRight
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(3, 1), Array(5, 1)), TrailingMinusNumbers:= _
        True
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    Columns("A:A").EntireColumn.AutoFit
    Columns("B:B").EntireColumn.AutoFit
    Columns("C:C").Select
    Selection.Delete Shift:=xlToLeft
    Columns("C:C").EntireColumn.AutoFit
      
    Cells.Select
        With Selection
       .Hyperlinks.Delete
    End With
    
    Range("B1").Select
    Range("A1:C200").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        Columns("A:C").Select
    Range("C1").Activate
    Selection.Font.Underline = xlUnderlineStyleSingle
    Selection.Font.Underline = xlUnderlineStyleNone
    Selection.Font.ColorIndex = 0
    Columns("A:A").Select
    Selection.NumberFormat = "000"
    Range("A1").Activate
End Sub

En vous remerciant.

A voir également:

Amélioration code
Code asci - Guide
Code puk bloqué - Guide
Code telephone oublié - Guide
Code blocks free - Télécharger - Langages
Code windows 10 - Guide

2 réponses

Réponse 1 / 2

gbinforme Messages postés 14946 Date d'inscription lundi 18 octobre 2004 Statut Contributeur Dernière intervention 24 juin 2020 4 684
7 déc. 2015 à 11:34

Bonjour,

Pas facile sans savoir ce que tu veux faire mais tu peux simplifier ainsi, a priori :

Private Sub CommandButton1_Click()
   Columns("B:D").Insert Shift:=xlToRight
    Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(3, 1), Array(5, 1)), TrailingMinusNumbers:= _
        True
    Columns("B").Delete Shift:=xlToLeft
    Columns("A:B").EntireColumn.AutoFit
    Columns("C").Delete Shift:=xlToLeft
    Columns("C").EntireColumn.AutoFit
    Cells.Hyperlinks.Delete
    Range("A1:C200").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    With Range("C1").Font
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 0
    End With
    Columns("A").NumberFormat = "000"
    Range("A1").Activate
End Sub

Réponse 2 / 2

vielhom Messages postés 24 Date d'inscription mercredi 11 novembre 2015 Statut Membre Dernière intervention 30 décembre 2015 3
7 déc. 2015 à 12:58

Bonjour gbinforme
Il s'agissait de mettre en ordre alphabétique une table des matières générées par Word.
Merci beaucoup, c'est parfait.

gbinforme Messages postés 14946 Date d'inscription lundi 18 octobre 2004 Statut Contributeur Dernière intervention 24 juin 2020 4 684
7 déc. 2015 à 18:06

Bonsoir et merci pour le retour.

Discussions similaires

Code de renvoi d'appel : Ooredo, Mobilis...

Acces à snapchat temporairement désactivé

Code Free Wifi Secure : comment en récupérer

Erreur 80072EFE windows update

Discussions similaires

Newsletters