Recuperation info texte

Bonjour à tous,

je suis tout nouveau sur le forum et j’ai besoin de vos lumières svp.

Voila mon problème, je reçois des fichiers dans lesquels je souhaiterais pouvoir en extraire des informations.

J'aimerais pouvoir extraire sous forme de tableau le texte figurant dans toutes les cellulles fusionnées identifiées en vert dans le fichier joint.

Pourriez vous m’aider svp.

Cordialement.

toutes les cellules fusionnées dans les lignes x6-x7 de gauche à droite ? Elles sont toujours au même endroit ? sinon, VBA

Bonjour,

les cellules concernées sont situées de gauche à droite dans les lignes 26-27, 36-37, 46-47, 56-57 et 66-67 et sont souvent au même endroit, parfois il y a juste moins de lignes.

bonjour,

Sub Collect_Fusion()
     Dim UN    As Range

     Application.FindFormat.Clear     'effacer le format de chercher
     Application.FindFormat.MergeCells = True     'cherche format "cellules fusionnées"

     Set dict = CreateObject("scripting.dictionary")     'cahier de brouillon
     With Worksheets("syno_9104144").Cells
          .Interior.Color = xlNone     'no coleur

          Set c0 = .Range("a" & Rows.Count)     'point de départ = assez au bout de la feuille
          Set c = .Find(What:=What, after:=c0, SearchOrder:=xlByRows, searchDirection:=xlNext, SearchFormat:=True)     'premiere cellule fusionnée
          If Not c Is Nothing Then     'il y a des cellules fusionnées
               fa = c.Address     'memorisez la première address
               Do     'boucle
                    With c.MergeArea     'toutes les cellule de la même plage
                         If .Rows.Count = 2 And .Row > 20 Then     'exactement 2 lignes fusionnées et la ligne >20
                              If UN Is Nothing Then Set UN = c Else Set UN = Union(UN, c)     'collectioner ces cellules
                              dict(c.Address) = c.Address & " : " & c.Value     'quelles données veut-on voir ?
                         End If
                    End With

                    Set c = .Find(What:=What, after:=c, SearchOrder:=xlByRows, searchDirection:=xlNext, SearchFormat:=True)     'prochain cellule fusionnée
               Loop While c.Address <> fa     '
          End If
     End With

     If UN Is Nothing Then
          MsgBox "rien trouvé"
     Else
          UN.Interior.ColorIndex = 3     'coleur rouge pour ces cellules
          MsgBox i & vbLf & Join(dict.items, vbLf)     'messagebox
     End If
End Sub

Super merci beaucoup vous êtes un super Forum

J'ai encore 2 petites questions:

1- Quand j'applique le code, une fenêtre pop up apparait bien avec le texte dont j'ai besoin, mais je ne peux pas copié cette liste.

2- Dois-je faire des modification pour pouvoir appliquer ce code à d'autre fichier?

Encore merci pour votre aide.

Bien cordialement.

re, la code est un petit peu changé pour vos 2 points

pour chercher dans une autre feuille, changez le nom ici

With Workbooks("AutreFichier.xlsx").Worksheets("syno_9104144").Cells

pour les cellules pour le resultat, changez ici

With Sheets("resultat").Range("A1")

 sub Collect_Fusion()

     Dim UN    As Range

     Application.FindFormat.Clear     'effacer le format de chercher
     Application.FindFormat.MergeCells = True     'cherche format "cellules fusionnées"

     Set dict = CreateObject("scripting.dictionary")     'cahier de brouillon
     With Worksheets("syno_9104144").Cells
          .Interior.Color = xlNone     'no coleur

          Set c0 = .Range("a" & Rows.Count)     'point de départ = assez au bout de la feuille
          Set c = .Find(What:=What, after:=c0, SearchOrder:=xlByRows, searchDirection:=xlNext, SearchFormat:=True)     'premiere cellule fusionnée
          If Not c Is Nothing Then     'il y a des cellules fusionnées
               fa = c.Address     'memorisez la première address
               Do     'boucle
                    With c.MergeArea     'toutes les cellule de la même plage
                         If .Rows.Count = 2 And .Row > 20 Then     'exactement 2 lignes fusionnées et la ligne >20
                              If UN Is Nothing Then Set UN = c Else Set UN = Union(UN, c)     'collectioner ces cellules
                              dict.Add c.Address, c.Value     'quelles données veut-on voir ?
                         End If
                    End With

                    Set c = .Find(What:=What, after:=c, SearchOrder:=xlByRows, searchDirection:=xlNext, SearchFormat:=True)     'prochain cellule fusionnée
               Loop While c.Address <> fa     '
          End If
     End With

     If UN Is Nothing Then
          MsgBox "rien trouvé"
     Else
          UN.Interior.ColorIndex = 3     'coleur rouge pour ces cellules
          'MsgBox i & vbLf & Join(dict.items, vbLf)     'messagebox
          With Sheets("resultat").Range("A1")
               .Resize(, 2).EntireColumn.ClearContents
               .Resize(dict.Count).Value = Application.Transpose(dict.keys)
               .Offset(, 1).Resize(dict.Count).Value = Application.Transpose(dict.items)
               .Resize(, 2).EntireColumn.AutoFit
          End With

     End If

End Sub

Merci beaucoup,

quand j'applique le nouveau code j'ai une fenêtre qui apparait avec

" erreur d’exécution 9 l'indice n'appartient pas à la selection"

re,

les 2 fichiers en annexe et tous les 2 doivent être ouvert au moment de lancer le macro.

Vous pouvez changer les variables au debut de la module.

Super merci infiniment je vais essayer ça!