Sélectionner les lignes comportant tous un X dans la même colonne ds une autre feuill

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Sheets("INSCRIPTIONS").Activate

For i = 2 To Range("A6553").End(xlUp).Row

        If Cells(i, 4) = "X" Then
            derligne = Sheets("4 STOCK ").Range("A65535").End(xlUp).Row + 1
            Range(Cells(i, 1), Cells(i, 3)).Cut Destination:=Sheets("4 STOCK ").Range("A" & derligne)
            Rows(i).Delete
            
        End If
        
Next i

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Plage As String, Derlig As Long
 If Not Intersect(Target, Range("E3:N" & Range("C" & Rows.Count).End(xlUp).Row)) Is Nothing Then
    Plage = "B" & Target.Row & ":D" & Target.Row
    If WorksheetFunction.CountBlank(Range(Plage)) > 0 Then
        MsgBox "vous n'avez pas tout saisi"
        Exit Sub
    Else
        Derlig = Worksheets(CStr(Cells(2, Target.Column))).Range("B" & Rows.Count).End(xlUp).Row + 1
        Range(Plage).Copy Worksheets(CStr(Cells(2, Target.Column))).Range("B" & Derlig)
    End If
 End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r, i&, x, y, z, t, f$, tablo, j&
Set r = Intersect(Target, Range("E3:N" & Rows.Count), Me.UsedRange)
If r Is Nothing Then Exit Sub
For Each r In r 'si entrées multiples
  If r <> "" Then
    i = r.Row
    x = Cells(i, 2): y = Cells(i, 3): z = Cells(i, 4)
    If x = "" Or y = "" Or z = "" Then r.Value = "": GoTo 1
    t = x & y & z
    f = Trim(Cells(2, r.Column))
    With Sheets(f)
      tablo = Intersect(.Range("B2:D" & .Rows.Count), .UsedRange)
      For j = 2 To UBound(tablo)
        If tablo(j, 1) & tablo(j, 2) & tablo(j, 3) = t Then _
          MsgBox "La ligne " & i & " est déjà en feuille '" & f & "' !", 48: GoTo 1
      Next
      .Cells(.Rows.Count, 2).End(xlUp)(2).Resize(, 3) = Cells(i, 2).Resize(, 3).Value
    End With
  End If
1 Next
End Sub

Option Compare Text 'la casse est ignorée

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim base, col%, ub&, tablo, i&, t$, j&
base = Feuil1.Range("A1:A2", Feuil1.UsedRange) 'CodeName de la feuille
For col = 5 To UBound(base, 2)
  If Trim(base(2, col)) = Sh.Name Then
    ub = UBound(base)
    tablo = Sh.Range("A1:A2", Sh.UsedRange)
    For i = 3 To UBound(tablo)
      t = tablo(i, 2) & tablo(i, 3) & tablo(i, 4)
      If t <> "" Then
        For j = 3 To ub
          If base(j, 2) & base(j, 3) & base(j, 4) = t And base(j, col) <> "" Then GoTo 1
        Next
      End If
      Sh.Cells(i, 2).Resize(, 100).ClearContents 'effacement
1   Next
    '---tri alphabétique sur les noms---
    Sh.Range("B3", Sh.Cells(Sh.Rows.Count, 100)).Sort Sh.[C3], Header:=xlNo
    Exit For
  End If
Next
End Sub