mes routines vba

adaptation de ces exemples:
ex1

mots clés
resize & co
usedRange 

mon adaptation code:
Public Sub CopyRows()
    Sheets("filtration").Select
    ' Find the last row of Sheet2
    FinalRow2 = Cells(Rows.Count, 1).End(xlUp).Row
   
    Sheets("chronologie").Select
    ' Find the last row of data1
    FinalRow1 = Cells(Rows.Count, 1).End(xlUp).Row
    ' Loop through each row
    For x = 2 To FinalRow1
        ' Decide if to copy based on column B
        ThisValue = Cells(x, 2).Value
        'If ThisValue = "Zedet" Then
        If (ucase(ThisValue) Like "*ZEDET*") Then
            ActiveCell.Interior.Color = RGB(252, 179, 48)
            Cells(x, 1).Resize(1, 3).Copy
            Sheets("filtration").Select
            NextRow2 = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Cells(NextRow2, 1).Select
            ActiveSheet.Paste
            Sheets("chronologie").Select
        End If
    Next x
End Sub

Sub test1()
Dim ws As Worksheet
For Each ws In Sheets
If ws.Name <> "Récap" Then 'sauf exemple
ws.Activate
 'ton code
 Next ws
 End Sub
 
Sub es()
 Dim ws As Worksheet
  For Each ws In Sheets(Array("feuil1", "feuil2", "feuil3"))
ws.Activate
'ton code
Next ws
End Sub
 
 
Sub test()

Dim sh as worksheet

x = Sheets.Count

For cpt = 1 To x

    If Sheets(cpt).Name <> "B" Then

    Sheets(cpt).Range("A2").Copy Worksheets("B").Range("A" & Worksheets("B").Range("A65536").End(xlUp).Row + 1)

    End If

Next

End Sub



 
 
' met 21 dans M1
Sub testEachSheet()

Worksheets(Array("chronologie", "chrono", "feuil1")).Select
Range("M1").Select
Selection.Value = 21
Worksheets(1).Select

End Sub







http://dmcritchie.mvps.org/excel/sheets.htm donne de nombreux exples dont:

Sub testEachSheet()

Worksheets(Array("chronologie", "chrono", "feuil1")).Select
Range("M1").Select
Selection.Value = 21
Worksheets(1).Select

End Sub


  Sub MsgBoxAllMySheets()
    Dim sht As Worksheet
    For Each sht In Sheets
      MsgBox sht.Name
    Next sht
  End Sub
  
  Sub AllSheetsColorFormulas()
    Dim sht As Worksheet
    For Each sht In Sheets
      On Error Resume Next 'in case no formulas
      sht.Cells.SpecialCells(xlFormulas). _
            Interior.ColorIndex = 6
          Next sht
  End Sub
  
  
  'Looping through a list of sheets

   Sub ARRAY_sheetnames()
   Dim wksht As Worksheet
   Dim i As Long
         Dim wkshtnames()     'This is an array definition
    i = 0
    For Each wksht In ActiveWorkbook.Worksheets
        i = i + 1
        ReDim Preserve wkshtnames(1 To i)
        wkshtnames(i) = wksht.Name
    Next wksht

    For i = LBound(wkshtnames) To UBound(wkshtnames)
        MsgBox wkshtnames(i)
    Next i
    End Sub
    
    
    'Create a list of Sheet Names from list in Column A, identified in Col B
Sub SelectSheetsBasedOn_B()
  Dim rng As Range, cell As Range
  Dim arrNames() As String, i As Long
  On Error Resume Next
  Set rng = Range("B:B").SpecialCells(xlConstants, xlNumbers)
  If Err.Number <> 0 Then
    MsgBox "Error " & Err.Number & " -- " & Err.Description
    Exit Sub
  End If
  On Error GoTo 0
  If Not rng Is Nothing Then
      'dimension to max possible names in array
      ReDim arrNames(1 To rng.Count)
      For Each cell In rng
        If cell.Value = 1 Then
           i = i + 1
           arrNames(i) = cell.Offset(0, -1).Value
        End If
      Next cell
  End If
  'reduce to names to be used
  ReDim Preserve arrNames(1 To i)
  Sheets(arrNames).Select ' a selectionné les feuilles du vecteur
End Sub


'Remove ALL commas from text constants in all workbooks.  Warning watch out for CSV file type data.

  Option Explicit
  Sub WsReplaceLooseCommas()
     Dim ws As Worksheet
      For Each ws In ActiveWorkbook.Worksheets
      
      'ws.Cells.SpecialCells(xlCellTypeConstants, 2). _
         'Replace What:=",", Replacement:=" ", LookAt:=xlPart, _
          'SearchOrder:=xlByRows, MatchCase:=False
      Next ws
  End Sub