Autres Concaténation de résultat (numéros) dans une cellule par VBA

[Webperegrino]

[Excel 2003 et Excel 2016]
Bonsoir le Forum,
Voici un fichier pour lequel je coince depuis plusieurs jours pour une formule à écrire en VBA pour extraire des numéros de références et les ranger les uns après les autres dans une cellule de la feuille résultat.

... à moins que vous proposiez quelque lignes de macro plus évidentes, et fiables.

Formule actuelle en A31 :
Cette formule fonctionne pour une recherche sur la ligne 61 de Sheets("ARCH2") pour mettre le résultat en feuille Sheets("REGROUPJourLieu")
et donne un résultat (nombre) en cellule RJL.[A31] de Sheets("REGROUPJourLieu") avec Set RJL = Sheets("REGROUPJourLieu")

=SI(ET(ARCH2!B61=REGROUPJourLieu!B2;TROUVE(B4;ARCH2!D61;1)=1);SI(ESTERREUR(TROUVE(B4;ARCH2!D61;1));"";ARCH2!A61);"")

L'objectif est de rendre cette formule variable à partir de la ligne 40
- Si Date en colonne B de Sheets("ARCH2") égale à celle de de B2 de Sheets("REGROUPJourLieu")
- et si en colonne D de Sheets("ARCH2") on retrouve la portion de texte qui est en B4 de Sheets("REGROUPJourLieu")
- alors on ajoute le n° de fiche trouvé dans la colonne A de Sheets("ARCH2") dans B31 de Sheets("REGROUPJourLieu")
à la suite des autres n° de fiches qui y sont déjà placés par cette recherche

Comment faire pour consulter toutes les lignes de Sheets("ARCH2"), entre ligne 40 et la ligne .Range("D" & Rows.Count).End(xlUp).Row
pour incrémenter les résultats dans la cellule B31, avec une séparation par "une virgule puis un blanc" sauf pour le dernier trouvé et placé dans cette cellule ?

Merci pour votre aide,
Les formules placées en A25:A31 pourraient ainsi disparaître car la macro VBA ferait le nécessaire pour tout afficher en cellule ... sans le message d'erreur de type 1004, comme actuellement.
Cordialement,
Webperegrino

 

[Webperegrino]

Bonjour Le Forum,
Je pense avoir trouvé une solution acceptable ; ce n'est pas très "PRO" mais ça fonctionne.
S'il existe une programmation qui donnerai un résultat plus esthétique et surtout une réponse plus rapide pour l'affichage, je suis preneur.
Cordialement,
Webperegrino

 

[Dranreb]

Bonsoir.
Je l'aurais écrit comme ça :

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim TDon(), L&, Arg As String, TJn() As String, J&
   If Not Intersect([B4], Target) Is Nothing Then
      TDon = Feuil1.UsedRange.Value
      Arg = Me.[B4].Value
      ReDim TJn(1 To 50)
      For L = 1 To UBound(TDon, 1)
         If Split(TDon(L, 4) & vbLf, vbLf)(0) = Arg Then J = J + 1: TJn(J) = "n° " & TDon(L, 1)
         Next L
      If J > 0 Then
         ReDim Preserve TJn(1 To J)
         [B31].Value = Join(TJn, ", ")
      Else: [B31].Value = Empty: End If: End If
   End Sub

 

[Webperegrino]

Bonsoir Le Forum,
Bonsoir Dranreb : merci pour votre intervention,
En effet c'est plus rapide.
Toutefois avec votre création m'allonge considérablement le résultat.
Il me semble que le critère Date y a été oublié...
Avec la mienne la sélection est parfaite avec :

If Tr = [B4] [B]And Ars.Range("B" & i) = [B2][/B] Then

Merci de vous pencher sur cette anomalie.
Cordialement,
Webperegrino

 

[Dranreb]

Effectivement je n'avais pas fait attention à la date.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim TDon(), L&, Arg As String, Dat As Date, TJn() As String, J&
   If Not Intersect([B4,B2], Target) Is Nothing Then
      TDon = Feuil1.UsedRange.Value
      Arg = Me.[B4].Value
      Dat = Me.[B2].Value
      ReDim TJn(1 To 50)
      For L = 1 To UBound(TDon, 1)
         If Split(TDon(L, 4) & vbLf, vbLf)(0) = Arg And TDon(L, 2) = Dat Then
            J = J + 1: TJn(J) = "n° " & TDon(L, 1): End If
         Next L
      If J > 0 Then
         ReDim Preserve TJn(1 To J)
         [B31].Value = Join(TJn, ", ")
      Else: [B31].Value = Empty: End If: End If
   End Sub