amelioration de macro

[MINO]

hallo ,
svp de m´aider a ameliore mon macro , il se fonctionne b1 mais il est un peut lang s´il ya pleusieur Excel ouvert
Code :

Sub sup()
'
dl = Range("A65000").End(xlUp).Row
Dim Ws As Worksheet

For Each Ws In ActiveWorkbook.Worksheets
Ws.Select Replace:=False

Ws.Select
Ws.Name = "Lager"
Columns("A:A").Select
ActiveWorkbook.Worksheets("Lager").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Lager").Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Lager").Sort
.SetRange Range("A1:A" & dl)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Next Ws
With ActiveSheet
lig = .Cells.Find(What:="*VERTEILER*", LookIn:=xlValues).Row
.Rows("2:" & lig).EntireRow.Delete
End With
Range("A1") = "ARTIKEL MENGE W-LG LGM-NR/ART PLATZ DATUM LS/SER/STK-B WAQS..PLI. G V"
Range("A1:A" & dl).Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(14, 1), Array(23, 1), Array(28, 1), Array(39, 2), _
Array(45, 4), Array(52, 1), Array(65, 1), Array(70, 1)), TrailingMinusNumbers:=True
Columns("I:I").Select
Selection.Delete Shift:=xlToLeft

Range("A1").Select
For Each cel In Range("A1:A" & dl)
cel.Value = Replace(cel.Value, " ", "")
Next
For Each cel In Range("A1:A" & dl)
cel.Value = Replace(cel.Value, "/", "")
Next
Range("I2:I" & dl) = "=+DATE(YEAR(F2),MONTH(F2)+6,DAY(F2))<TODAY()"

ActiveWorkbook.SaveAs Filename:="C:\Temp\Start_lager.xls"
End Sub

 

[Guest]

Re : amelioration de macro

Bonjour,

Devrait faire gagner un peu de temps:

Sub sup()
    '
    dl = Range("A65000").End(xlUp).Row
    Dim Ws As Worksheet
    Dim oldCalculation As XlCalculation
    oldCalculation = Application.Calculation 'retenir le mode de calcul en cours
    
    'Figer les éléments d'application chronophages
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    For Each Ws In ActiveWorkbook.Worksheets
        With Ws
            .Name = "Lager"
            With .Sort
                .SortFields .Clear
                .SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .SetRange Range("A1:A" & dl)
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        End With
    Next Ws
    
    With ActiveSheet
        lig = .Cells.Find(What:="*VERTEILER*", LookIn:=xlValues).Row
        .Rows("2:" & lig).EntireRow.Delete
    
    .Range("A1") = "ARTIKEL MENGE W-LG LGM-NR/ART PLATZ DATUM LS/SER/STK-B WAQS..PLI. G V"
    .Range("A1:A" & dl).TextToColumns Destination:=Range("A1"), _
                                     DataType:=xlFixedWidth, _
                                     FieldInfo:=Array(Array(0, 1), Array(14, 1), Array(23, 1), Array(28, 1), Array(39, 2), _
                                                      Array(45, 4), Array(52, 1), Array(65, 1), Array(70, 1)), TrailingMinusNumbers:=True
    .Columns("I:I").Delete Shift:=xlToLeft
    With .Range("A1:A" & dl)
        .Replace " ", "", xlValues, xlByRows, False
        .Replace "/", "", xlValues, xlByRows, False
    Next
    .Range("I2:I" & dl).Formula = "=+DATE(YEAR(F2),MONTH(F2)+6,DAY(F2))<TODAY()"
    End With
    
    'Remettre les paramètres application à leur état initial
    Application.Calculation = oldCalculation
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    ActiveSheet.Calculate
    
    ActiveWorkbook.SaveAs Filename:="C:\Temp\Start_lager.xls"
End Sub

A+

 

[Efgé]

Re : amelioration de macro

Bonjour MINO, Bonjour Hasco
J'attendais un petit exemple pour vérifier mais il y a quand même quelque chose qui m'intrigue dans le code d'origine:

 For Each Ws In ActiveWorkbook.Worksheets
        With Ws
            .Name = "Lager"

Chez moi, sous 2007, ça plante dès la deuxième feuille puisque Lager existe déja...

Cordialement

 

[Guest]

Re : amelioration de macro

Re,

Oui forcément, mais comme tu le dis, sans fichier exemple je me contente d'être... (je n'ose le dire!)

Et avec tous les select de sa macro QUELLE est la feuille correspondant à ActiveSheet en fin de macro?

A+

 

[MINO]

Re : amelioration de macro

Hallo Hasco, Efgé
ci joint un exemple pour mieux comprendre
et merci
Mino

 

[Efgé]

Re : amelioration de macro

Re
D'accord...
Je pense qu'il s'agit d'un .CSV (donc une seule feuille)
Le temps doit certainement venir du fait que la dernière ligne n'est pas recalculée après la suppression des lignes.
Une proposition, dans la même veine que le code d'origine:

Sub sup_2()
Dim dl As Long, lig As Long, cel As Range
Application.ScreenUpdating = False
With ActiveSheet
    .Name = "Lager"
    dl = .Cells(.Rows.Count, 1).End(3).Row
    With .Sort
        With .SortFields
            .Clear
            .Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending
        End With
        .SetRange Range("A1:A" & dl)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    lig = .Cells.Find(What:="*VERTEILER*", LookIn:=xlValues).Row
    .Rows("2:" & lig).EntireRow.Delete
    lig = .Cells(.Rows.Count, 1).End(3).Row
    .Range("A1") = "ARTIKEL MENGE W-LG LGM-NR/ART PLATZ DATUM LS/SER/STK-B WAQS..PLI. G V"
    .Range("A1:A" & lig).TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
    FieldInfo:=Array(Array(0, 1), Array(14, 1), Array(23, 1), Array(28, 1), Array(39, 2), _
    Array(45, 4), Array(52, 1), Array(65, 1), Array(70, 1)), TrailingMinusNumbers:=True
    .Columns("I:I").Delete Shift:=xlToLeft
    For Each cel In Range("A1:A" & lig)
        cel.Value = Replace(Replace(cel.Value, "/", ""), " ", "")
    Next cel
    Range("I2:I" & lig).Formula = "=+DATE(YEAR(F2),MONTH(F2)+6,DAY(F2))<TODAY()"
    .Columns.AutoFit
End With
ActiveWorkbook.SaveAs Filename:="C:\Temp\Start_lager.xls"
End Sub

Cordialement

 

[MINO]

Re : amelioration de macro

merci Efgé c vraiment genial .

 

[Efgé]

Re : amelioration de macro

Re
Merci aussi à Hasco