XL 2010 Mauvaise utilisation de la fonction InStr

[cathodique]

Bonsoir,

J’ai 2 tableaux TbA représentant un historique avec en colonne 2 des numéros de dossier (NoDossier), je voudrais récupérer les données de la colonne 5 (Cat.) dans le second tableau TbB (auquel on ajoute une colonne par code) ayant les mêmes NoDossier en colonne 1.

Je rencontre une difficulté récupérer les données (Cat.) séparées par un slash (/) mais sans doublons.

Je vous donne un exemple concret du fichier joint (nb: j'ai ajouté une feuille résultat juste pour vérifier l'exactitude du rendu du code).

Dans le tableau TbA, le Nodossier 2021134 se retrouve :
en ligne 2 a pour Cat.=Cd
en ligne 65 a pour Cat.=Fa
en ligne 68 a pour Cat.=Fa

Je voudrais reporter dans la 13ème colonne du tableau TbB -à Cd/Fa, pas 2 fois Fa
Pour 2023133 --à Cat= Cd/Fa
Pour 2023135 --à Cat= Cd/Ad

Option Explicit
Option Compare Text
'------------------------------------------------------
Sub Completer_Categorie_TbB()   'à exploiter
   Dim b, c, i As Long, clé, p As Long, x As Byte
i = 0
   b = [TbB].Value 'Fiche
   c = [TbA].Value 'Affectation

   ReDim Preserve b(1 To UBound(b), 1 To UBound(b, 2) + 1)

   For Each clé In Range("TbA[NoDossier]")

      i = i + 1
      p = Application.Match(clé, Application.Index(c, , 2), 0)   ' Recherche dans colonne NoDossier du tableau c()
    
If b(p, 13) = "" Then
b(p, 13) = c(i, 5)
Else

x = InStr(c(i, 5), b(p, 13))
Debug.Print "x= " & x, b(p, 13)
If x = 0 Then
b(p, 13) = b(p, 13) & "/" & c(i, 5)
Else

End If
End If
Next

   With Feuil3
      .Activate
      .[A1].CurrentRegion.ClearContents
      .[A1].Resize(UBound(b), UBound(b, 2)) = b
    End With
End Sub

Mon code fait le boulot, mais je ne bloque pour faire ce que j’ai essayé d’expliquer ci-dessus.

Je n’arrive pas à bien utiliser la Fonction InStr.

J’espère avoir été clair, avec tous mes remerciements.

Bonne soirée

 

[jurassic pork]

Hello,
voici ce que je te propose comme solution :
pour chaque animal dans la feuille Fiche on va chercher dans la feuille Affectation toutes les catégories qui lui sont affectées.
Pour se faire on utilise un tableau qui contient les NoDossier du Tableau Tba. On va chercher dedans en utilisant la fonction Findall.
FindAll(what, arr, c, col, dico) va chercher what dans arr (ici arr = Tba[NoDossier]) et peuple le dictionnaire dico (un dictionnaire évite les doublons) avec la valeur de la colonne col du tableau c (ici c = Tba)
Pour transcrire les clés du dictionnaire en chaîne on utilise la fonction Dico2String
lDico2String(dico, sep) renvoie les clés du dictionnaire dico sous forme de chaîne en utilisant le séparateur sep.
Voici le code (ne pas faire attention aux instructions en commentaire utilisées pour calculer le temps d'exécution) :

Sub Completer_Categorie_TbB()   'à exploiter
   Dim b, c, d, i As Long, clé, dico As Object
   'Dim bm As New cBenchmark
   Set dico = CreateObject("Scripting.Dictionary")
   i = 1
   b = [TbB].Value 'Fiche
   c = [Tba].Value 'Affectation
   d = Application.Transpose(Range("Tba[NoDossier]").Value)
   'bm.TrackByName "Init"
   ReDim Preserve b(1 To UBound(b), 1 To UBound(b, 2) + 1)
   'bm.TrackByName "Redim"
   For Each clé In Range("TbB[NoDossier]")
      FindAll clé, d, c, 5, dico
      'Debug.Print Dico2String(dico, "/")
      b(i, 13) = Dico2String(dico, "/")
      i = i + 1
   Next
  ' bm.TrackByName "Find"
   With Feuil3
      .Activate
      .[A1].CurrentRegion.ClearContents
      .[A1].Resize(UBound(b), UBound(b, 2)) = b
      .[A1].CurrentRegion.Font.Size = 8
   End With
   'bm.TrackByName "EcrireResultats"
End Sub

Function FindAll(what, arr, c, col, dico) As Boolean
Dim i As Integer
FindAll = False
dico.RemoveAll
On Error Resume Next
For i = LBound(arr) To UBound(arr)
    If arr(i) = what Then
    FindAll = True
    dico.Add CStr(c(i, col)), i
    End If
Next
End Function

Function Dico2String(dico, sep) As String
  Dico2String = Join(dico.Keys, sep)
End Function

Voici les performances :

IDnr	Name	Count	Sum of tics	Percentage	Time sum
0​	Init	1​	71​	0,03%​	7100 ns
1​	Redim	1​	53​	0,02%​	5300 ns
2​	Find	1​	67 046	24,89%​	6,7 ms
3​	EcrireResultats	1​	202 175	75,06%​	20 ms
	TOTAL	4​	269 345	100,00%​	27 ms

Ami calmant, J.P

 

[cathodique]

Hello,
voici ce que je te propose comme solution :
pour chaque animal dans la feuille Fiche on va chercher dans la feuille Affectation toutes les catégories qui lui sont affectées.
Pour se faire on utilise un tableau qui contient les NoDossier du Tableau Tba. On va chercher dedans en utilisant la fonction Findall.
FindAll(what, arr, c, col, dico) va chercher what dans arr (ici arr = Tba[NoDossier]) et peuple le dictionnaire dico (un dictionnaire évite les doublons) avec la valeur de la colonne col du tableau c (ici c = Tba)
Pour transcrire les clés du dictionnaire en chaîne on utilise la fonction Dico2String
lDico2String(dico, sep) renvoie les clés du dictionnaire dico sous forme de chaîne en utilisant le séparateur sep.
Voici le code (ne pas faire attention aux instructions en commentaire utilisées pour calculer le temps d'exécution) :

Sub Completer_Categorie_TbB()   'à exploiter
   Dim b, c, d, i As Long, clé, dico As Object
   'Dim bm As New cBenchmark
   Set dico = CreateObject("Scripting.Dictionary")
   i = 1
   b = [TbB].Value 'Fiche
   c = [Tba].Value 'Affectation
   d = Application.Transpose(Range("Tba[NoDossier]").Value)
   'bm.TrackByName "Init"
   ReDim Preserve b(1 To UBound(b), 1 To UBound(b, 2) + 1)
   'bm.TrackByName "Redim"
   For Each clé In Range("TbB[NoDossier]")
      FindAll clé, d, c, 5, dico
      'Debug.Print Dico2String(dico, "/")
      b(i, 13) = Dico2String(dico, "/")
      i = i + 1
   Next
  ' bm.TrackByName "Find"
   With Feuil3
      .Activate
      .[A1].CurrentRegion.ClearContents
      .[A1].Resize(UBound(b), UBound(b, 2)) = b
      .[A1].CurrentRegion.Font.Size = 8
   End With
   'bm.TrackByName "EcrireResultats"
End Sub

Function FindAll(what, arr, c, col, dico) As Boolean
Dim i As Integer
FindAll = False
dico.RemoveAll
On Error Resume Next
For i = LBound(arr) To UBound(arr)
    If arr(i) = what Then
    FindAll = True
    dico.Add CStr(c(i, col)), i
    End If
Next
End Function

Function Dico2String(dico, sep) As String
  Dico2String = Join(dico.Keys, sep)
End Function

Voici les performances :

IDnr	Name	Count	Sum of tics	Percentage	Time sum
0​	Init	1​	71​	0,03%​	7100 ns
1​	Redim	1​	53​	0,02%​	5300 ns
2​	Find	1​	67 046	24,89%​	6,7 ms
3​	EcrireResultats	1​	202 175	75,06%​	20 ms
	TOTAL	4​	269 345	100,00%​	27 ms

Ami calmant, J.P

Bonjour @jurassic pork ,

Merci beaucoup. Tu me donnes un immense coup de pouce.
Bien que tes explications soient claires. Pourrais-tu Stp ajouter des commentaires dans tes fonctions.
Je voudrais les bien assimiler pour une réutilisation ou une adaptation dans d'autres fichiers similaires.

Encore merci.

Je te souhaite un très bon dimanche.

 

[jurassic pork]

Mettre des commentaires ça ne va pas apporter grand chose, il suffit de chercher la documentation pour les dictionnaires et les fonctions Application.Transpose (pour transformer une colonne de plage en tableau une dimension) et Join
La description des fonctions dans mon message précédent devrait alors suffire.

 

[cathodique]

Mettre des commentaires ça ne va pas apporter grand chose, il suffit de chercher la documentation pour les dictionnaires et les fonctions Application.Transpose (pour transformer une colonne de plage en tableau une dimension) et Join
La description des fonctions dans mon message précédent devrait alors suffire.

Merci beaucoup. Je vais essayer de compléter seul.
Là, tu as attiré mon attention. La fonction Application.Transpose risque de poser problème car le nombre de lignes dans mon fichier de travail est beaucoup plus grand que dans le joint.
Je sais que le nombre de ligne augmentera très rapidement.
En tout cas, je te remercie pour ton aide.

 

[jurassic pork]

Là, tu as attiré mon attention. La fonction Application.Transpose risque de poser problème car le nombre de lignes dans mon fichier de travail est beaucoup plus grand que dans le joint.

Combien de lignes ?

 

[job75]

Bonjour cathodique, jurassic pork, le forum,

Cette macro est simple et me paraît faire l'affaire :

Private Sub Worksheet_Activate()
Dim sep$, d As Object, tablo, i&, x$, y$, n&
sep = "/"
Set d = CreateObject("Scripting.Dictionary")
tablo = [TbA]
For i = 1 To UBound(tablo)
    x = CStr(tablo(i, 2))
    y = tablo(i, 5)
    If d.exists(x) Then
        y = sep & y
        If InStr(sep & d(x) & sep, y & sep) = 0 Then d(x) = d(x) & y
    Else
        d(x) = y
    End If
Next i
tablo = [TbB].Columns(1)
n = UBound(tablo)
ReDim resu(1 To n, 1 To 1)
For i = 1 To n
    resu(i, 1) = d(CStr(tablo(i, 1)))
Next i
'---restitution---
With [N2] 'à adapter
    .Resize(n) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
End With
End Sub

Elle se déclenche quand on active la 2ème feuille.

A+

 

[cathodique]

J'ai finalement réussi à faire ce truc à ma sauce pour le partage

Option Explicit
Option Compare Text

''=========================================================
Sub Completer_Categorie_TbB()   'à exploiter
   Dim b, c, i As Long, clé, p As Long, x As Byte, t, j As Byte, cle
   Dim d As Object, Cc
   Set d = CreateObject("scripting.dictionary")
   i = 0
   b = [TbB].Value   'Fiche
   c = [tba].Value   'Affectation

   ReDim Preserve b(1 To UBound(b), 1 To UBound(b, 2) + 1)

   For Each clé In Range("TbA[NoDossier]")

      i = i + 1
      p = Application.Match(clé, Application.Index(c, , 2), 0)   ' Recherche dans colonne NoDossier du tableau c()

      If IsEmpty(b(p, 13)) Then 'si destination vide
         b(p, 13) = c(i, 5)
      Else 'si destination non vide
         t = Split(b(p, 13), "/") '
         If UBound(t) = 0 Then 'si une occurence
            If t(0) <> c(i, 5) Then b(p, 13) = b(p, 13) & "/" & c(i, 5)
         Else 'plus d'une occurence
            d.RemoveAll 'on vide le dictionnaire
            For j = 0 To UBound(t)
               d(t(j)) = "" 'cat. sans doublon
            Next

            If d.Count > 1 Then 'si dictionnaire contient plus d'une cat.
               If d.exists(c(i, 5)) Then
                  Cc = Join(d.keys, "/")
               Else
                  Cc = Join(d.keys, "/") & "/" & c(i, 5)
               End If
               b(p, 13) = Cc
            End If
         End If
      End If
   Next
   With Feuil3 'juste pour vérifier que le rendu est juste'
      .Activate
      .[A1].CurrentRegion.ClearContents
      .[A1].Resize(UBound(b), UBound(b, 2)) = b
      .[A1].CurrentRegion.Font.Size = 8
   End With

End Sub

 

[cathodique]

Bonjour cathodique, jurassic pork, le forum,

Cette macro est simple et me paraît faire l'affaire :

Private Sub Worksheet_Activate()
Dim sep$, d As Object, tablo, i&, x$, y$, n&
sep = "/"
Set d = CreateObject("Scripting.Dictionary")
tablo = [TbA]
For i = 1 To UBound(tablo)
    x = CStr(tablo(i, 2))
    y = tablo(i, 5)
    If d.exists(x) Then
        y = sep & y
        If InStr(sep & d(x) & sep, y & sep) = 0 Then d(x) = d(x) & y
    Else
        d(x) = y
    End If
Next i
tablo = [TbB].Columns(1)
n = UBound(tablo)
ReDim resu(1 To n, 1 To 1)
For i = 1 To n
    resu(i, 1) = d(CStr(tablo(i, 1)))
Next i
'---restitution---
With [N2] 'à adapter
    .Resize(n) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
End With
End Sub

Elle se déclenche quand on active la 2ème feuille.

A+

Bonjour @job75 ,
Merci beaucoup. Cette fois-ci, tu ne pourras pas me dire que je n'ai pas mentionné que le rendu sur une feuille n'est fait que pour vérifier le résultat.

Je testerai ton code cet après-midi. Je le trouve assez concis par rapport au mien obtenu après maintes plantages.

Encore merci.
Bon dimanche.

 

[job75]

Pour tester j'ai recopié le tableau A2:E68 (TbA) de la 1ère feuille sur 30 016 lignes :

- la macro de jurassic pork post #2 s'exécute chez moi en 2,12 secondes

- ma macro post #7 s'exécute en 0,12 seconde

- la macro de cathodique post #8 prend 19 minutes 36 secondes.

 

[job75]

On notera que dans la fonction FindAll jurassic pork déclare i As Integer au lieu de As Long.

Cela limite le tableau TbA de la 1ère feuille à 32767 lignes.

 

[jurassic pork]

On notera que dans la fonction FindAll jurassic pork déclare i As Integer au lieu de As Long.

Hello,
Effectivement , mais au moment où j'ai écrit ma macro je ne savais pas qu'il y avait beaucoup plus de lignes que dans le classeur exemple (cathodique ne pas répondu pour ma question sur le nombre de lignes).
En tout cas la macro de job75 est la plus performante car il ne fait pas une recherche pour chaque ligne du tableau de sortie mais il construit un dictionnaire avec les valeurs concaténées de la colonne Cat. en balayant le tableau TbA en une seule fois. Il utilise ensuite ce dictionnaire pour compléter le tableau TbB.
Pour le test avec beaucoup de lignes , sans le classeur réel c'est difficile à générer car il faudrait de nouveaux pensionnaires dans le tableau TbB . Cela conduirait dans ma macro et celle de cathodique à plus de recherches et donc à des temps beaucoup plus importants.
A noter que l'on peut aussi utiliser PowerQuery pour faire ce type de traitement.
Exemple
1 - Une requête pour regrouper la table TbA par NoDossier et concaténer les Cat. :
let

Source = Excel.CurrentWorkbook(){[Name="TbA"]}[Content],
    #"Type modifié" = Table.TransformColumnTypes(Source,{{"Date", type datetime}, {"NoDossier", Int64.Type}, {"IdAnimal", type any}, {"IdPerson", type text}, {"Cat.", type text}}),
    #"Lignes groupées" = Table.Group(#"Type modifié", {"NoDossier"}, {{"Cat2",each List.Distinct([#"Cat."],Comparer.OrdinalIgnoreCase), type nullable text}}),
    #"Added Custom" = Table.AddColumn(#"Lignes groupées", "Custom", each Text.Combine([Cat2],"/")),
    #"Removed Columns" = Table.RemoveColumns(#"Added Custom",{"Cat2"}),
    #"Colonnes renommées" = Table.RenameColumns(#"Removed Columns",{{"Custom", "Cat."}})
in
    #"Colonnes renommées"

et une requête pour ajouter la colonne Cat. à la table TbB :
let

Source = Excel.CurrentWorkbook(){[Name="TbB"]}[Content],
    #"TbC" = Table.TransformColumnTypes(Source,{{"NoDossier", Int64.Type}, {"Date", type datetime}, {"Espece", type text}, {"Race_Type", type text}, {"Nom", type text}, {"Date_Naiss", type datetime}, {"Sexe", type text}, {"Couleurs", type text}, {"IdAnimal", Int64.Type}, {"Observation", type text}, {"Caractère", type text}, {"DateDC", type datetime}}),
    #"Requêtes fusionnées" = Table.NestedJoin(TbC, {"NoDossier"}, GrouperCat, {"NoDossier"}, "TbA_req", JoinKind.LeftOuter),
    #"TbA_req développé" = Table.ExpandTableColumn(#"Requêtes fusionnées", "TbA_req", {"Cat."}, {"Cat."})
in
    #"TbA_req développé"

GrouperCat est le nom de la première requête
je ne suis pas un spécialiste de PowerQuery, il y a certainement plus simple.

Ami calmant, J.P