Sub Macro1()
Dim F As Worksheet 'déclare la variable F (onglet DEF)
Dim T As Worksheet 'déclare la variable T (onglet DET)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim D As Object 'déclare la variable D (Dictionnaire D)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim L As Integer 'déclare la variable L (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Set F = Worksheets("DEF") 'définit l'onglet F
Set T = Worksheets("DET") 'définit l'onglet T
T.Cells.ClearContents 'efface d'éventuelles anciennes données de l'onglet T
TV = F.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 3 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la troisième)
'si les deux premiers caractères de la donnée ligne I colonne 1 de TV sont "AA", alimente le dictionnaire D avec la donnée ligne I colonne 5 de TV
If Left(TV(I, 1), 2) = "AA" Then D(TV(I, 5)) = ""
Next I 'prochaine ligne de la boucle
TMP = D.Keys 'récupère dans le tableau temporaire TMP la liste des élément du dictionnaire D sans doublon
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments du tableau temporaire TMP
K = 1 'initialise la variable K
For I = 3 To UBound(TV) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la troisième)
'condition : si les deux premiers caractères de la donnée ligne I colonne 1 de TV sont "AA" et si la donnée ligne I colonne 5 de TV correspond à TMP(J)
If Left(TV(I, 1), 2) = "AA" And TV(I, 5) = TMP(J) Then
ReDim Preserve TL(1 To UBound(TV, 2), 1 To K) 'redimensionne le tableau des lignes TL (autant de lignes que TV a de colonnes, K colonnes)
For L = 1 To UBound(TV, 2) 'boucle 3 sur toutes les colonnes L du tableau des valeurs TV
TL(L, K) = TV(I, L) 'récupère dans la ligne L de TL la donnée en colonne L de TV (=> transposition)
Next L 'prochaine colonne de la boucle 3
K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
End If 'fin de la condition
Next I 'prochaine ligne de la boucle 2
'définit la cellule de destination DEST (A1 si A1 est vide sinon la seconde cellule vide de la ligne 1)
If T.Range("A1").Value = "" Then Set DEST = T.Range("A1") Else Set DEST = T.Cells(1, Application.Columns.Count).End(xlToLeft).Offset(0, 2)
DEST.Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Index(TV, 2) 'renvoie DEST redimensionnée la seconde ligne du tableau des valeurs TV
DEST.Offset(1, 0).Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL) 'revoie dans DEST décalée d'une ligne et redimensionnée le tableau TL transposé
Next J 'prochain élément de la boucle 1
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim code As Range, ville As Range, t, xcode$, d As Object, i&, xville$, n&, a()
Set code = [H2]: Set ville = [J2] 'à adapter
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
If FilterMode Then ShowAllData 'si la feuille est filtrée
ville(2).Resize(Rows.Count - ville.Row, 3).Delete xlUp 'RAZ
t = [A2].CurrentRegion.Resize(, 5) 'matrice, plus rapide
xcode = code & "*"
'---liste de validation des villes---
Set d = CreateObject("Scripting.Dictionary")
If code <> "" Then
For i = 2 To UBound(t)
If t(i, 1) Like xcode And LCase(t(i, 4)) = "oui" Then d(t(i, 5)) = ""
Next
End If
ville.Validation.Delete
With [Z:Z] 'colonne auxiliaire
.ClearContents
If d.Count Then
With .Resize(d.Count)
.Value = Application.Transpose(d.keys)
.Sort .Cells(1), xlAscending, Header:=xlNo 'tri alphabétique
ville.Validation.Add xlValidateList, Formula1:="=" & .Address
End With
End If
End With
'---tableau des résultats---
If code = "" Or Application.CountIf([Z:Z], ville) = 0 Then ville = ""
xville = ville
If xville <> "" Then
For i = 2 To UBound(t)
If t(i, 1) Like xcode And LCase(t(i, 4)) = "oui" And t(i, 5) = xville Then
n = n + 1
ReDim Preserve a(1 To 3, 1 To n)
a(1, n) = t(i, 1)
a(2, n) = t(i, 3)
a(3, n) = t(i, 2)
End If
Next
End If
If n Then
With ville(2).Resize(n, 3)
.Value = Application.Transpose(a)
.Borders.Weight = xlThin
End With
End If
Application.EnableEvents = True 'réactive les évènements
End Sub
Aucun problème, mettre le code dans la feuille "DET" :Mais la feuille "DET" m'est indispensable dans mon fichier,
Private Sub Worksheet_activate()
Worksheet_Change [A1] 'lance la macro
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim code As Range, ville As Range, t, xcode$, d As Object, i&, xville$, n&, a()
Set code = [C2]: Set ville = [E2] 'à adapter
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
If FilterMode Then ShowAllData 'si la feuille est filtrée
ville(2).Resize(Rows.Count - ville.Row, 3).Delete xlUp 'RAZ
t = Sheets("DEF").[A2].CurrentRegion.Resize(, 5) 'matrice, plus rapide
xcode = code & "*"
'---liste de validation des villes---
Set d = CreateObject("Scripting.Dictionary")
If code <> "" Then
For i = 2 To UBound(t)
If t(i, 1) Like xcode And LCase(t(i, 4)) = "oui" Then d(t(i, 5)) = ""
Next
End If
ville.Validation.Delete
With [Z:Z] 'colonne auxiliaire
.ClearContents
If d.Count Then
With .Resize(d.Count)
.Value = Application.Transpose(d.keys)
.Sort .Cells(1), xlAscending, Header:=xlNo 'tri alphabétique
ville.Validation.Add xlValidateList, Formula1:="=" & .Address
End With
End If
End With
'---tableau des résultats---
If code = "" Or Application.CountIf([Z:Z], ville) = 0 Then ville = ""
xville = ville
If xville <> "" Then
For i = 2 To UBound(t)
If t(i, 1) Like xcode And LCase(t(i, 4)) = "oui" And t(i, 5) = xville Then
n = n + 1
ReDim Preserve a(1 To 3, 1 To n)
a(1, n) = t(i, 1)
a(2, n) = t(i, 3)
a(3, n) = t(i, 2)
End If
Next
End If
If n Then
With ville(2).Resize(n, 3)
.Value = Application.Transpose(a)
.Borders.Weight = xlThin
End With
End If
Application.EnableEvents = True 'réactive les évènements
End Sub
Private Sub Worksheet_Activate()
Worksheet_Change [A1] 'lance la macro
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim code$, villes As Range, t, ville As Range, xville$, a(), n&, i&
code = "AA*" 'à adapter, ne pas oublier l'astérisque...
Set villes = [B2,F2] 'adresses des tableaux à adapter
t = Sheets("DEF").[A2].CurrentRegion.Resize(, 5) 'matrice, plus rapide
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
If FilterMode Then ShowAllData 'si la feuille est filtrée
For Each ville In villes
xville = ville
Erase a: n = 0 'RAZ
For i = 2 To UBound(t)
If t(i, 1) Like code And LCase(t(i, 4)) = "oui" And t(i, 5) = xville Then
n = n + 1
ReDim Preserve a(1 To 3, 1 To n)
a(1, n) = t(i, 1)
a(2, n) = t(i, 3)
a(3, n) = t(i, 2)
End If
Next i
ville.CurrentRegion.Offset(1).Clear 'RAZ
If n Then
With ville(2).Resize(n, 3)
.Value = Application.Transpose(a) 'restitution
.Borders.Weight = xlThin 'bordures
.Columns(2).NumberFormat = "[h]:mm:ss"
.Columns(2).HorizontalAlignment = xlCenter
End With
End If
Next ville
Application.EnableEvents = True 'réactive les évènements
End Sub