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