Tri auto sans toucher à la mise en forme des cellules

Bonsoir tout le mondes,

J'aimerais sur ce code le tri automatique (croissant) en fonction de la colonne "B" dans la feuille "NE"

ou

le tri, du résultat dans la feuille "recherche" sans pour autant toucher à la mise en forme des cellules du classeur.

Ce code fournit par "belkacem64".

j'ai essayé plusieurs choses, mais rien y fait (suis pas encore au point avec le VBA)

Car quand, je fais ma recherche (par atelier) sur la feuille "recherche", il ne me les affiches pas dans l’ordre croissant.

code de la (feuille1) "recherche"

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Application.Goto Range("A14"), True

If Target.Address = Range("C3").Address Or Target.Address = Range("C6").Address Then RECHERCHER

If Target.Address = Range("C3").Address Then LALISTE

End Sub

code du module1

Sub RECHERCHER()

Dim T As Double, R As Double, C1 As String, C2 As String, Ary()
Dim This_Sh As Worksheet, Sh_NE As Worksheet
Set This_Sh = Sheets("RECHERCHE")
Set Sh_NE = Sheets("NE")
C1 = This_Sh.Range("C3").Value:
C2 = This_Sh.Range("C6").Value

If C1 = "" And C2 = "" Then
This_Sh.Range("A14:D" & This_Sh.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row).ClearContents
This_Sh.Range("A14:D" & This_Sh.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row).ClearContents
Exit Sub
End If

This_Sh.Range("A14:D" & This_Sh.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row).ClearContents
LsRow = Sh_NE.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
Application.ScreenUpdating = False

    For T = 3 To LsRow
        If C1 = "" Then GoTo iNext
        If CStr(UCase(Sh_NE.Cells(T, 1))) = CStr(UCase(C1)) Then
iNext:
        If C2 = "" Then GoTo iNexte
        If CStr(UCase(Sh_NE.Cells(T, 2))) = CStr(UCase(C2)) Then
iNexte:
       R = R + 1
                ReDim Preserve Ary(1 To 4, 1 To R)
                Ary(1, R) = Sh_NE.Cells(T, 2):
                Ary(2, R) = Sh_NE.Cells(T, 3)
                Ary(3, R) = Sh_NE.Cells(T, 4):
                Ary(4, R) = Sh_NE.Cells(T, 5)
  End If
  End If
  Next
If R > 0 Then This_Sh.Range("A14").Resize(R, 4).Value = WorksheetFunction.Transpose(Ary)
If Err Then Err.Clear
Erase Ary
Application.ScreenUpdating = True
End Sub

Sub LALISTE()
Application.ScreenUpdating = False
Dim This_Sh As Worksheet, Sh_NE As Worksheet
Set This_Sh = Sheets("RECHERCHE")
Set Sh_NE = Sheets("NE")
Dim Rng As Range, Last As Long
With Sh_NE
Last = .Cells(Rows.Count, 2).End(xlUp).Row
Set Rng = .Range("B3:B" & Last)
This_Sh.Range("I:I").ClearContents
Rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=This_Sh.Range("I14"), UNIQUE:=True
End With
Application.ScreenUpdating = False
End Sub

Si vous avez plus simple à me donner ce que je dois mettre et où le mettre, pour moi c'est pareil

Merci et bonne nuits à tous.

Salut

le code sera comme ca

Sub RECHERCHER()

Dim T As Double, R As Double, C1 As String, C2 As String, Ary()
Dim This_Sh As Worksheet, Sh_NE As Worksheet, LR As Long
Set This_Sh = Sheets("RECHERCHE")
Set Sh_NE = Sheets("NE")
C1 = This_Sh.Range("C3").Value
C2 = This_Sh.Range("C6").Value

If C1 = "" And C2 = "" Then
This_Sh.Range("A14:D" & This_Sh.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row).ClearContents
This_Sh.Range("A14:D" & This_Sh.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row).ClearContents
Exit Sub
End If

This_Sh.Range("A14:D" & This_Sh.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row).ClearContents
LsRow = Sh_NE.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
Application.ScreenUpdating = False
    For T = 3 To LsRow
        If C1 = "" Then GoTo iNext
        If CStr(UCase(Sh_NE.Cells(T, 1))) = CStr(UCase(C1)) Then
iNext:
        If C2 = "" Then GoTo iNexte
        If CStr(UCase(Sh_NE.Cells(T, 2))) = CStr(UCase(C2)) Then
iNexte:
       R = R + 1
                ReDim Preserve Ary(1 To 4, 1 To R)
                Ary(1, R) = Sh_NE.Cells(T, 2):
                Ary(2, R) = Sh_NE.Cells(T, 3)
                Ary(3, R) = Sh_NE.Cells(T, 4):
                Ary(4, R) = Sh_NE.Cells(T, 5)
  End If
  End If
  Next
If R > 0 Then
With This_Sh
    .Range("A14").Resize(R, 4).Value = WorksheetFunction.Transpose(Ary)
    LR = .Cells(Rows.Count, 2).End(xlUp).Row + 1
    .Range("A14:D" & LR).Sort Key1:=.Range("A14"), Order1:=xlDescending  ' xlAscending
    End With
    End If
If Err Then Err.Clear
Erase Ary
Application.ScreenUpdating = True
End Sub

Bonjour,

Merci et en plus tu m'as laisser la variable pour un tri décroissant

Très bonne journée belkacem64