1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42
| Private Sub Worksheet_Change(ByVal Target As Range)
Dim R As Range, Rng As Range
Dim CR As Integer, COL As Integer
If Not Intersect(Target, [B1]) Is Nothing Then
'appiquer le filtre sur la première feuille
Sheets("Feuil1").Range("A:L").AutoFilter field:=3, Criteria1:=Target.Value
'vider les données de la deuxième feuille
Sheets("Feuil2").Range("B5:B7,A11:J1000").Clear
'définir les donnée à transferer (sur base de la première colonne)
Set Rng = Sheets("Feuil1").Cells(1, 1).CurrentRegion
'si le filtre ne renvoie pas de valeur alors une erreur survient
'ici on décide donc de sortir de la procedure si c'est le cas
On Error GoTo EmptyFilter
Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
'remise à zero du gestionnaire d'erreur
On Error GoTo 0
'passons en revue les différentes données à tranferer
For Each R In Rng
'appliquons les données du tableau de la feuille 1 sur la feuille 2
Sheets("Feuil2").Range("B5") = R.Offset(0, 1) 'Demandeur
Sheets("Feuil2").Range("B6") = R.Offset(0, 4) 'Date emission
Sheets("Feuil2").Range("B7") = R.Offset(0, 3) 'Compte
Sheets("Feuil2").Range("A11").Offset(CR, 0) = R.Offset(0, 5) 'Repere Laboratoire
Sheets("Feuil2").Range("B11").Offset(CR, 0) = R.Offset(0, 6) 'Repère Demandeur
Sheets("Feuil2").Range("C11").Offset(CR, 0) = R.Offset(0, 7) 'C
Sheets("Feuil2").Range("D11").Offset(CR, 0) = R.Offset(0, 8) 'S
Sheets("Feuil2").Range("E11").Offset(CR, 0) = R.Offset(0, 9) 'o
Sheets("Feuil2").Range("F11").Offset(CR, 0) = R.Offset(0, 10) 'N
Sheets("Feuil2").Range("G11").Offset(CR, 0) = R.Offset(0, 11) 'H
'incrémentons l'offset de ligne
CR = CR + 1
Next R
'hide unwanted columns
Columns("C:H").Hidden = False
For COL = 3 To 7
If Application.WorksheetFunction.Sum(Rng.Offset(0, COL + 4)) = 0 Then Columns(COL).EntireColumn.Hidden = True
Next COL
End If
Exit Sub
EmptyFilter:
End Sub |
Partager