Public Const NomTSRésumé = "TS_Résumé"
Public Const Nom = "Contractants"
Public Const Recherche = "NomCherché"
Public Const Repère = "Col4"
'
'Extraire des TS suivis les enregistrements correspondant au nom recherché
Sub Extraire()
Dim tb, TbGlob, Trans, Tb_TS, First As Boolean, No
Dim Taille As Long, Taille1a As Long, Taille1b As Long, Taille2 As Long, i As Long, j As Long
Tb_TS = Sh_Tables.[TS_NomsTS]
If Evaluate(Recherche) = "" Then 'si effacement du nom recherché
With [TS_Résumé]
.ClearContents
.ListObject.Resize .Offset(-1).Resize(2)
End With
Exit Sub
End If
First = True
For Each TS In Tb_TS 'Parcourrir tous les tableaux à traiter
'Mettre dans tb les lignes correspondant au nom recherché (dans la cellule "NomCherché" (constante Recherche))
tb = Evaluate("LET(Lst,FILTER(" & TS & "," & TS & "[" & Nom & "]=" & Recherche & ",""""),IF(Lst="""","""",Lst))")
If IsArray(tb) Then '(il y a au moins une ligne filtrée)
'Traitement pour le cas où l'on n'a qu'une ligne retournée (tb est un tableau à une dimension)
On Error Resume Next: dd = UBound(tb, 2): No = Err.Number: On Error GoTo 0
If No <> 0 Then
Taille = UBound(tb, 1)
ReDim Trans(1 To 1, 1 To Taille)
For i = 1 To Taille
Trans(1, i) = tb(i)
Next
tb = Trans
End If
'Tb est un tableau à 2 dimensions ...
If First Then
TbGlob = tb: First = False 'Pour le 1er TS suivi
Else 'Pour les TS suivants
'(On aurait pu faire avec redim preserve puis transposer ... mais bon !)
Taille1a = UBound(TbGlob, 1)
Taille1b = UBound(tb, 1)
Taille2 = UBound(TbGlob, 2)
ReDim Trans(1 To Taille1a + Taille1b, 1 To Taille2)
'Reprise des valeurs déjà collectées
For i = 1 To Taille1a: For j = 1 To Taille2
Trans(i, j) = TbGlob(i, j)
Next j, i
'Ajout des nouvelles valeurs
For i = 1 To Taille1b: For j = 1 To Taille2
Trans(i + Taille1a, j) = tb(i, j)
Next j, i
TbGlob = Trans
End If
End If
Next
'Mise à jour du TS Cible (Constante NomTSRésumé)
If IsEmpty(TbGlob) Then
'Pas de données filtrées (le nom cherché ne matche pas)
With [TS_Résumé]
.ClearContents
.ListObject.Resize .Offset(-1).Resize(2)
End With
Else
'Coller les données collectées dans le "TS TS_Résumé"
With [TS_Résumé]
.ClearContents
.ListObject.Resize .Offset(-1).Resize(UBound(TbGlob) + 1)
End With
[TS_Résumé] = TbGlob
End If
End Sub
'Mise à jour des TS suivis
Sub MàJ_TSlistes(Cible As Range)
Dim wsh As Worksheet, Zone As Range, Ligne As Range, C As Range
Dim Tb_TS, TS, Idx As Long, No, Col As String
Set wsh = Sh_Listes
Tb_TS = Sh_Tables.[TS_NomsTS]
For Each Zone In Cible.Areas: For Each Ligne In Zone.Rows '(Si sélection multiple, par zone de la sélection puis par ligne de chaque zone)
'Numéro d'identification de la ligne concernée
No = Intersect(Ligne.EntireRow, wsh.Evaluate(NomTSRésumé & "[" & Repère & "]")).Value
For Each TS In Tb_TS
'N° de la ligne dans le TS
Idx = 0
On Error Resume Next: Idx = WorksheetFunction.Match(No, wsh.Evaluate(TS & "[" & Repère & "]"), 0): On Error GoTo 0
If Idx > 0 Then
For Each C In Ligne
'Nom de la colonne
Col = Intersect(C.EntireColumn, wsh.Evaluate(NomTSRésumé & "[#Headers]"))
'Modification de la cellule
wsh.Evaluate(TS & "[" & Col & "]").Cells(Idx) = C
Next C
End If
Next TS
Next Ligne, Zone
End Sub
'MàJ de la liste des "Contractants" pour la validation de données du nom recherché
Sub MàJ_Liste_Contractants()
Dim DC As Object
Set DC = CreateObject("Scripting.Dictionary")
For Each TS In Sh_Tables.[TS_NomsTS]
tb = Evaluate("UNIQUE(" & TS & "[" & Nom & "])")
'Traitement pour le cas où l'on n'a qu'une ligne retournée
On Error Resume Next: dd = UBound(tb, 2): No = Err.Number: On Error GoTo 0
If No <> 0 Then
DC(tb(1)) = tb(1)
Else
For i = 1 To UBound(tb, 1)
DC(tb(i, 1)) = tb(i, 1)
Next
End If
Next
'Liste des noms trouvé
Items = DC.Items
nb = DC.Count
'Passage en 2 dimensions
ReDim tt(1 To nb, 1 To 1)
For i = 1 To nb
tt(i, 1) = Items(i - 1)
Next
'Tri
tb = WorksheetFunction.Sort(tt, 1, 1)
'MàJ du TS "TS_Noms"
With Sh_Tables.[TS_Noms]
.ClearContents
.ListObject.Resize .Offset(-1).Resize(nb + 1)
End With
Sh_Tables.[TS_Noms] = tb
End Sub
