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

Webperegrino · 5 Août 2019

[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 · 6 Août 2019

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 · 6 Août 2019

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

VB:

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 · 6 Août 2019

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 :

VB:

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

Merci de vous pencher sur cette anomalie.
Cordialement,
Webperegrino

Dranreb · 7 Août 2019

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

VB:

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

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

Webperegrino

XLDnaute Impliqué

Pièces jointes

Webperegrino

XLDnaute Impliqué

Pièces jointes

Dranreb

XLDnaute Barbatruc

Webperegrino

XLDnaute Impliqué

Dranreb

XLDnaute Barbatruc

Discussions similaires