Option Explicit
Option Base 1
Sub ExtraireMachinesNonSorties()
'
Dim oColAjout As Range
Dim TabCol, DerLigneNonSorties&
Dim OldCalculation&
'
' On empêche le rafraichissement d'écran et on modifie le mode
' de calcul (passage en manuel)
With Application
.ScreenUpdating = False
OldCalculation = .Calculation
.Calculation = xlCalculationManual
End With
'
' On détermine la première colonne vide à droite du tableau,
' et on initialise oColAjout en conséquence (1 colonne, nb de
' lignes du tableau)
Set oColAjout = Range('IV1').End(xlToLeft).Offset(0, 1).Resize(Range('A65536').End(xlUp).Row, 1)
'
' avec oColAjout
With oColAjout
'
' on place un titre sur la première ligne
.Item(1) = 'Non sorties'
'
' on entre la formule (voir MEFC) sur la 2ème ligne
.Item(2).FormulaLocal = '=SI(NB.SI(E:E;E2)=1;''X'';'''')'
'
' que l'on recopie jusqu'en bas du tableau
.Item(2).AutoFill Destination:=.Item(2).Resize(.Rows.Count - 1, 1)
'
' on lance le calcul uniquement pour cette colonne
.Calculate
'
' puis on fait un Copier/Collage spécial valeurs
.Copy
.PasteSpecial xlPasteValues
'
' Tri du tableau en fonction de cette dernière colonne :
' suite au calcul de la formule, toutes les lignes sans
' doublon auront un 'X' dans la colonne ajoutée. On trie
' en fonction de cette colonne pour que tous les 'sans doublons'
' soient placés en haut du tableau.
Range('A1').CurrentRegion.Sort key1:=.Item(2), order1:=xlDescending, header:=xlYes
'
' on efface les données précédentes de Feuil2
Sheets('Feuil2').Cells.Delete
'
' puis on copie toutes les lignes du tableau dont la dernière
' colonne contient 'X' (mais sans copier cette dernière colonne)
' après avoir déterminé la dernière ligne contenant un 'X'
TabCol = .Value
For DerLigneNonSorties = 1 To (UBound(TabCol) - 1)
If TabCol(DerLigneNonSorties + 1, 1) ‹› 'X' Then
Exit For
End If
Next DerLigneNonSorties
With .Item(1)
Range('A1').Resize(DerLigneNonSorties, .Column - 1).Copy (Sheets('Feuil2').Range('A1'))
End With
'
' on supprime la colonne qui avait été ajoutée
.Delete
End With
'
' puis on remet les chose en ordre avant de sortir ;-)))
With Range('A1')
.CurrentRegion.Sort key1:=Range('E2'), order1:=xlAscending, header:=xlYes
.Select
End With
With Application
.Calculation = OldCalculation
.ScreenUpdating = True
End With
End Sub