Simplification Macros

GADENSEB

GADENSEB

XLDnaute Impliqué
Re bonjour le Forum,

Je cherche à simplifier ces macros dans le module 2

Qui peut m'aider, svp ?

Bonne aprem.

Seb


Code: 
Sub CONVERTIRFORMATS()

    'Convertir en format DATE
Worksheets("BASE EMPLOI").Select
 
     
         Range("T65536").End(xlUp).Select
   Selection.TextToColumns Destination:=Range("T2"), DataType:=xlFixedWidth, _
    FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
      Selection.NumberFormat = "dd/mm/yy"
        
        Range("U65536").End(xlUp).Select
   Selection.TextToColumns Destination:=Range("U2"), DataType:=xlFixedWidth, _
     FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
             Selection.NumberFormat = "dd/mm/yy"
        
        Range("AB65536").End(xlUp).Select
   Selection.TextToColumns Destination:=Range("AB2"), DataType:=xlFixedWidth, _
    FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
          Selection.NumberFormat = "dd/mm/yy"
        
        Range("AJ65536").End(xlUp).Select
  Selection.TextToColumns Destination:=Range("AJ2"), DataType:=xlFixedWidth, _
   FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
            Selection.NumberFormat = "dd/mm/yy"
        
        Range("AK65536").End(xlUp).Select
Selection.TextToColumns Destination:=Range("AK2"), DataType:=xlFixedWidth, _
 FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
       Selection.NumberFormat = "dd/mm/yy"
        
         Range("AL65536").End(xlUp).Select
Selection.TextToColumns Destination:=Range("AL2"), DataType:=xlFixedWidth, _
      FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
               Selection.NumberFormat = "dd/mm/yy"
               
        Range("AM65536").End(xlUp).Select
Selection.TextToColumns Destination:=Range("AM2"), DataType:=xlFixedWidth, _
      FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
               Selection.NumberFormat = "dd/mm/yy"
        
         Range("AT65536").End(xlUp).Select
   Selection.TextToColumns Destination:=Range("AT2"), DataType:=xlFixedWidth, _
       FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
          Selection.NumberFormat = "dd/mm/yy"
        
      Range("BB65536").End(xlUp).Select
  Selection.TextToColumns Destination:=Range("BB2"), DataType:=xlFixedWidth, _
      FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
           Selection.NumberFormat = "dd/mm/yy"






End Sub

Code: 
Sub CONVERTIRDATES()
Worksheets("BASE EMPLOI").Select
   Range("T2:T1500").Select
    Selection.TextToColumns Destination:=Range("T2"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
        
    Range("U2:U1500").Select
    Selection.TextToColumns Destination:=Range("U2"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True

    Range("AB2:AB1500").Select
    Selection.TextToColumns Destination:=Range("AB2"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True

    Range("AJ2:AJ1500").Select
    Selection.TextToColumns Destination:=Range("AJ2"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
        
        Range("AK2:AK1500").Select
    Selection.TextToColumns Destination:=Range("AK2"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
        
         Range("AL2:AL1500").Select
    Selection.TextToColumns Destination:=Range("AL2"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
        
        Range("AM2:AM1500").Select
    Selection.TextToColumns Destination:=Range("AM2"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
        
        Range("AU2:AU1500").Select
    Selection.TextToColumns Destination:=Range("AT2"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
        
         Range("BB2:BB1500").Select
    Selection.TextToColumns Destination:=Range("BA2"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
        
     
End Sub




'======= DEFINIT LA ZONE D'IMPRESSION =============

Code: 
Sub ZONEIMPRESSION()
Worksheets("BASE EMPLOI").Select
'Détermine la zone d'impression

ActiveSheet.PageSetup.PrintArea = Range("A1:BB" & _
Range("A65536").End(xlUp).Row).Address

End Sub
'============ CHANGE LA COULEUR DES COLONNES SOMMAIRES =========
Code: 
Sub COULEURCOLONNES()

Worksheets("BASE EMPLOI").Select
    ' Trait du bas sur toutes les lignes
    Range("A1").Select
    Selection.CurrentRegion.Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("A2").Select


    ' Pas de trait sur les colonnes sommaires
    
    Range("F:F").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    
    Range("M:M").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    
    Range("S:S").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    
    Range("Z:Z").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    
    Range("AE:AE").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    
    Range("AR:AR").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
   
    Range("A1").Select
    
    ' Copie les couleurs des colonnes
    Range("F3").Select
    Selection.AutoFill Destination:=Range("F3:F1500"), Type:=xlFillDefault
    Range("F3:F1500").Select
    
    Range("M3").Select
    Selection.AutoFill Destination:=Range("M3:M1500"), Type:=xlFillDefault
    Range("M3:M1500").End(xlUp).Select
    
    Range("S3").Select
    Selection.AutoFill Destination:=Range("S3:S1500"), Type:=xlFillDefault
    Range("S3:S1500").End(xlUp).Select
    
    Range("Z3").Select
    Selection.AutoFill Destination:=Range("Z3:Z1500"), Type:=xlFillDefault
    Range("Z3:Z1500").End(xlUp).Select
    
    Range("AE3").Select
    Selection.AutoFill Destination:=Range("AE3:AE1500"), Type:=xlFillDefault
    Range("AE3:AE1500").End(xlUp).Select
    
    
    Range("AR3").Select
    Selection.AutoFill Destination:=Range("AR3:AR1500"), Type:=xlFillDefault
    Range("AR3:AR1500").End(xlUp).Select
    
    
    
    Range("A2").Select

End Sub

Code: 
Sub CENTURYGOTHIC8()
Worksheets("BASE EMPLOI").Select
'Met en Century Gothics 8
    Cells.Select
    With Selection.Font
        .Name = "Century Gothic"
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With Selection.Font
        .Name = "Century Gothic"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("B2").Select

End Sub


Code: 
Sub MFCATRAITER()
' Mise en forme conditionnelle "A TRAITER"
Worksheets("BASE EMPLOI").Select
    ActiveWindow.SmallScroll Down:=-12
    Range("B65536").End(xlUp).Select
    Selection.FormatConditions.Add Type:=xlTextString, String:="A TRAITER", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 90
        .Gradient.ColorStops.Clear
    End With
    With Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(0)
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(0.5)
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(1)
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    
  

End Sub
 

Pièces jointes

  • BASE EMPLOI - DEMO.xlsm
    225.7 KB · Affichages: 68
  • BASE EMPLOI - DEMO.xlsm
    225.7 KB · Affichages: 71
  • BASE EMPLOI - DEMO.xlsm
    225.7 KB · Affichages: 75
Trier par date Trier par votes
Regueiro

Regueiro

XLDnaute Impliqué
Re : Simplification Macros

Bonsoir le Forum,GADENSEB
Pour le 1er code concernant le Format date :
PHP: 
Sub CONVERTIRFORMATSV02()
Dim Derlig
Dim Cel As Range
Dim Col1, Col2, Col3
Col1 = "U2:T"
Col2 = "AB2:AB"
Col3 = "AJ2:AM"

With Sheets("BASE EMPLOI")
Derlig = [A65000].End(xlUp).Row
'xxxxxxxxx 1er Code OK xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Each Cel In Union(Range("U2:T" & Derlig), Range("AB2:AB" & Derlig), Range("AJ2:AM" & Derlig))
'Cel.NumberFormat = "dd/mmmm/yy"
'Next Cel
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

'xxxxxxxxx 2ème Code OK xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
For Each Cel In Union(Range(Col1 & Derlig), Range(Col2 & Derlig), Range(Col3 & Derlig))
Cel.NumberFormat = "dd/mm/yy"
Next Cel

End With
End Sub

Tu peux résoudre tout tes problèmes sans Macro
Tu transformes tes données en tableaux
Insertion Tableau
Ensuite tu règles tes formats, une fois pour toute.
Tes nouvelles données auront les formats initiaux.
A+
 
Vote positif 0 Vote négatif
Regueiro

Regueiro

XLDnaute Impliqué
Re : Simplification Macros

Re bonsoir le Fil

Variante 1
Si tu transformes tes données en tableaux comme indiquer sur le Post N°2
Voici le code très simplifier
PHP: 
Option Explicit
Option Base 1

Sub FormatdatedansTableau1()
Dim F As Worksheet
Dim LST As ListObject
Dim i
Dim Cel As Range
Set F = Sheets("Nouvelle BAse")
Set LST = F.ListObjects("Tableau1")
MsgBox F.Name & "-" & LST.Name
For Each i In Array(20, 21)     'Colonne T et U
For Each Cel In LST.DataBodyRange.Columns(i).Cells
    Cel.NumberFormat = "dd/mm/yy"
    Cel.Interior.ColorIndex = 7
Next Cel
Next i
End Sub

Autrement une autre approche pour ton cas :
PHP: 
Sub CONVERTIRFORMATSV05()
Dim F As Worksheet
Dim Derlig
Dim MesPlages As Range
Dim Col As Range, Cel As Range
Dim Col1, Col2, Col3, Col4, Col5, ColTout
Set F = Sheets("BASE EMPLOI")
    With F
        Derlig = .[A65000].End(xlUp).Row
        MsgBox Derlig & " - " & F.Name
        'Col1 = Replace("U2:T" & Derlig, Chr(34), Chr(32))
        Col1 = "U2:T" & Derlig
        'Col1 = Replace(Col1, Chr(34), Chr(32))      'chr(32) = Espace
        Col2 = "AB2:AB" & Derlig '& "," & "AJ2:AM" & Derlig
        Col3 = "AJ2:AM" & Derlig
        Col4 = "AT2:AT" & Derlig
        Col5 = "BB2:BB" & Derlig
        ColTout = Col1 & "," & Col2 & "," & Col3 & "," & Col4 & "," & Col5
        
        'Set MesPlages = Union(Range(Col1), Range(Col2), Range(Col3))
        Set MesPlages = .Range(ColTout)
        MsgBox MesPlages.Address
        'For Each Col In MesPlages
        For Each Cel In MesPlages
        'For Each Cel In Col.Cells
            Cel.NumberFormat = "dd/mm/yy"
            Cel.Interior.ColorIndex = 7
        Next Cel
    'Next Col
End With
End Sub
Je pense que les pros du VBA pourront encore réduire ce code.
En incluant les numéros de colonnes à traiter dans un Array par exemple
A+
Bonne soirée
 
Vote positif 0 Vote négatif
GADENSEB

GADENSEB

XLDnaute Impliqué
Re : Simplification Macros

Merci !

de mon côté
j'ai cette version !


Code: 
Sub CONVERTIRFORMATS(arrColonne As Variant)
    Dim I As Long, nbLignes As Long
 
    'Convertir en format DATE
    Sheets("BASE EMPLOI").Activate
 
    For I = 0 To UBound(arrColonne)
        nbLignes = Cells(Rows.Count, arrColonne(I)).End(xlUp).Row
        Range(Cells(2, arrColonne(I)), Cells(nbLignes, arrColonne(I))).Select
        Selection.TextToColumns Destination:=Cells(2, arrColonne(I)), DataType:=xlFixedWidth, _
        FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
        Selection.NumberFormat = "dd/mm/yy"
    Next
 
End Sub
 
Vote positif 0 Vote négatif
GADENSEB

GADENSEB

XLDnaute Impliqué
Re : Simplification Macros

Oups je l'avais pas vu !!

voici la macro dans son entier

Code: 
Sub MacroX()
    Dim arrColonnes As Variant
    arrColonnes = Array("T", "U", "AB", "AJ", "AK", "AL", "AM", "AT", "BB")
    CONVERTIRFORMATS arrColonnes
End Sub
 
Sub CONVERTIRFORMATS(arrColonne As Variant)
    Dim I As Long, nbLignes As Long
 Application.ScreenUpdating = False
    'Convertir en format DATE
    Sheets("BASE EMPLOI").Activate
 
    For I = 0 To UBound(arrColonne)
        nbLignes = Cells(Rows.Count, arrColonne(I)).End(xlUp).Row
        Range(Cells(2, arrColonne(I)), Cells(nbLignes, arrColonne(I))).Select
        Selection.TextToColumns Destination:=Cells(2, arrColonne(I)), DataType:=xlFixedWidth, _
        FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
        Selection.NumberFormat = "dd/mm/yy"
    Next
    Sheets("GESTION").Activate
    Range("A1").Select
 Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
Regueiro

Regueiro

XLDnaute Impliqué
Re : Simplification Macros

Re
Merci
C'est exactement ce que je voulais savoir :
Sub MacroX()
Dim arrColonnes As Variant
arrColonnes = Array("T", "U", "AB", "AJ", "AK", "AL", "AM", "AT", "BB")
CONVERTIRFORMATS arrColonnes
End Sub
Cliquez pour agrandir...

Par contre à quoi te sert :
Selection.TextToColumns Destination:=Cells(2, arrColonne(I)), DataType:=xlFixedWidth, _
FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
Cliquez pour agrandir...
Si j'ai bien compris ton code tu veux mettre au format Date uniquement, alors le code du Dessus est superflu
d'après moi ?
Selection.NumberFormat = "dd/mm/yy"
Cliquez pour agrandir...

Voici un code plus simple :
PHP: 
Sub essaiN02()
Dim arrColonne As Variant
Dim I As Variant
Dim x As Variant
Dim F As Worksheet
Dim Derlig
arrColonne = Array("T", "U", "AA")
Set F = Sheets("BASE EMPLOI")
Derlig = F.[A65000].End(xlUp).Row

For Each I In arrColonne
For Each x In Array(Val(Mid(Columns(I).Address(ReferenceStyle:=xlR1C1), 2)))
With F.Range(Cells(2, x), Cells(Derlig, x))
.NumberFormat = "dd/mm/yyyy"

End With

Next x
Next I
End Sub
A+
 
Vote positif 0 Vote négatif
GADENSEB

GADENSEB

XLDnaute Impliqué
Re : Simplification Macros

Merci pour le code

Code: 
Selection.TextToColumns Destination:=Cells(2, arrColonne(I)), DataType:=xlFixedWidth, _
FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True

Sert à a faire un copier coller valeur !
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Résolu(e)
XL 2021 Créer Macro permettant d'indexer des nouveaux clients ? [Résolu]
4 5 6
Réponses
82
Affichages
2 K
fanou06
F
R
  • Question
XL 2016 Rendre plus lisible un code VBA
2
Réponses
23
Affichages
1 K
TooFatBoy
TooFatBoy
K
  • Question
XL 2019 Organiser le code VBA
Réponses
9
Affichages
564
Kevin38
K
H
  • Question
XL 2016 Mettre des titres avec une mise en forme spécifique
Réponses
1
Affichages
289
vgendron
vgendron
E
  • Résolu(e)
Microsoft 365 Convertir en -tete tableau en date
Réponses
14
Affichages
334
eric72
E
L
  • Question
Microsoft 365 Changement de couleurs de cellules dans plusieurs feuilles suite à une modification
Réponses
4
Affichages
355
lolo_excelbeginner
L
Syracoti
  • Résolu(e)
XL 2016 Changer de feuille dans une macro
2
Réponses
28
Affichages
3 K
Staple1600
Staple1600
S
  • Résolu(e)
Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear
2
Réponses
23
Affichages
1 K
AtTheOne
AtTheOne
A
  • Résolu(e)
Microsoft 365 With Selection.Parent.MailEnvelope.Item
Réponses
13
Affichages
521
patricktoulon
patricktoulon
piga25
  • Résolu(e)
XL 2016 Gestion d'erreur dans code
Réponses
6
Affichages
211
piga25
piga25

Membres actuellement en ligne

9 membres et 157 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 282
Messages
2 086 757
Membres
103 389
dernier inscrit
DEDE86