Macro active sur plusieurs feuilles

Bonjour a tous,

Je suis nouveau sur le forum.

Je cherche a activer ces macros sur plusieurs feuilles.

J'ai cherche (peut-etre mal) sur le forum avant de poster.

Merci a tous

Leo14

Sub supLignesRapide2()

Application.ScreenUpdating = False

a = Range("A1:A" & [A65000].End(xlUp).Row)

For i = LBound(a) To UBound(a)

If a(i, 1) Like "*GOULOTTE*" Then a(i, 1) = "sup" Else a(i, 1) = 0

Next i

Columns("b:b").Insert Shift:=xlToRight

[B1].Resize(UBound(a)) = a

[A1].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess

On Error Resume Next

Range("B1:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete

Columns("b:b").Delete Shift:=xlToLeft

End Sub

Sub supLignesRapide3()

Application.ScreenUpdating = False

a = Range("A1:A" & [A65000].End(xlUp).Row)

For i = LBound(a) To UBound(a)

If a(i, 1) Like "*CHASSIS*" Then a(i, 1) = "sup" Else a(i, 1) = 0

Next i

Columns("b:b").Insert Shift:=xlToRight

[B1].Resize(UBound(a)) = a

[A1].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess

On Error Resume Next

Range("B1:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete

Columns("b:b").Delete Shift:=xlToLeft

End Sub

Sub supLignesRapide4()

Application.ScreenUpdating = False

a = Range("A1:A" & [A65000].End(xlUp).Row)

For i = LBound(a) To UBound(a)

If a(i, 1) Like "*STRUCTURE*" Then a(i, 1) = "sup" Else a(i, 1) = 0

Next i

Columns("b:b").Insert Shift:=xlToRight

[B1].Resize(UBound(a)) = a

[A1].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess

On Error Resume Next

Range("B1:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete

Columns("b:b").Delete Shift:=xlToLeft

End Sub

Sub supLignesRapide5()

Application.ScreenUpdating = False

a = Range("A1:A" & [A65000].End(xlUp).Row)

For i = LBound(a) To UBound(a)

If a(i, 1) Like "*PROTECTION*" Then a(i, 1) = "sup" Else a(i, 1) = 0

Next i

Columns("b:b").Insert Shift:=xlToRight

[B1].Resize(UBound(a)) = a

[A1].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess

On Error Resume Next

Range("B1:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete

Columns("b:b").Delete Shift:=xlToLeft

End Sub

Sub supLignesRapide6()

Application.ScreenUpdating = False

a = Range("A1:A" & [A65000].End(xlUp).Row)

For i = LBound(a) To UBound(a)

If a(i, 1) Like "*ENTRETOISE*" Then a(i, 1) = "sup" Else a(i, 1) = 0

Next i

Columns("b:b").Insert Shift:=xlToRight

[B1].Resize(UBound(a)) = a

[A1].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess

On Error Resume Next

Range("B1:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete

Columns("b:b").Delete Shift:=xlToLeft

End Sub

Bonjour,

Une macro c'est du code exécutable, cela s'applique à ce à quoi tu lui dis de s'appliquer !

Là tu ne dis rien à tes macros, tu les laisses donc s'appliquer par défaut à la feuille active. Leur désigner une feuille te conduira à qualifier tes expressions et avoir donc un code plus rationnel er moins approximatif.

Cordialement.

Bonjour,

Un début de réponse à étudier.

Cdlt.

Option Explicit

Public Sub Delete_Rows()
Dim lastRow As Long, I As Long
Dim tbl As Variant
    With ActiveSheet
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        tbl = .Cells(1).Resize(lastRow).Value
        For I = LBound(tbl) To UBound(tbl)
            Select Case True
                Case tbl(I, 1) Like "GOULOTTE*" Or _
                     tbl(I, 1) Like "*CHASSIS*" Or _
                     tbl(I, 1) Like "*STRUCTURE*" Or _
                     tbl(I, 1) Like "*PROTECTION*" Or _
                     tbl(I, 1) Like "*ENTRETOISE*"
                    tbl(I, 1) = "sup"
                Case Else
                    tbl(I, 1) = 0
            End Select
        Next I
        Application.ScreenUpdating = False
        .Columns(2).Insert Shift:=xlToRight
        .Cells(2).Resize(UBound(tbl)) = tbl
        .Cells(1).CurrentRegion.Sort Key1:=.Cells(2), _
                                     Order1:=xlAscending, _
                                     Header:=xlGuess
        With .Cells(2)
            .Resize(lastRow).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
            .EntireColumn.Delete
        End With
    End With
End Sub

Merci Messieurs,

Je regarde cela et vous dit.

Je suis debutant et, je rame.

Cdlt.

Leo14