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