Microsoft 365 Importer certaines données d'un ou plusieurs fichiers txt dans des cellules d'une feuille Excel

[FCMLE44]

Bonjour

J'ai un ou plusieurs fichiers txt dans un répertoire.
Je souhaiterais ouvrir ces fichier et récupérer certaines données pour les mettre dans une feuille d'un fichier excel
Je sais que ca peut se faire en créant une boucle mais je vous avoue que je sèche un peu n'ayant jamais travaillé avec des fichiers txt

Je vous mets un exemple excel en pièce jointe
Je dois remonter le numéro de Sécu, les noms et prénoms et le montant

Quelqu'un aurait il une idée ?

Merci

 

[FCMLE44]

Bon j'ai mieux regardé vos fichiers, testez ce fichier (2) avec cette macro :

Option Compare Text 'la casse est ignorée

Sub Importer()
Dim chemin$, fichier$, x%, montant As Boolean, texte$, civ, p%, n&, a(), deb%, fin%
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.txt") '1er fichier txt du dossier
While fichier <> ""
    x = FreeFile
    Open chemin & fichier For Input As #x 'ouverture en lecture séquentielle
    montant = False
    While Not EOF(x)
        Line Input #x, texte
        texte = Replace(Replace(Replace(texte, "é", "é"), "è", "è"), "ê", "ê") 'épuration
        '---récupération du Montant à passer---
        If montant Then montant = False: If IsNumeric(texte) Then a(4, n) = CDbl(texte)
        '---nom---
        For Each civ In Array("Monsieur", "Madame", "Mademoiselle")
            p = InStr(texte, civ)
            If p Then
                n = n + 1
                ReDim Preserve a(1 To 4, 1 To n)
                a(1, n) = fichier
                deb = p + Len(civ)
                fin = InStr(texte, "Arrêt")
                If fin Then fin = fin - 1 Else fin = Len(texte)
                a(3, n) = Trim(Mid(texte, deb, fin - deb + 1))
                Exit For
            End If
        Next
        '---N°SS---
        p = InStr(texte, "SS :")
        If p Then
            deb = p + 4
            fin = Len(texte)
            a(2, n) = Trim(Mid(texte, deb, fin - deb + 1))
        End If
        '---Montant à passer---
        If texte = "Prestation complementaire" Then montant = True 'repérage
    Wend
    Close #x
    fichier = Dir 'fichier suivant
Wend
'---restitution---
With ActiveSheet 'à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A2]
        If n Then .Resize(n, 4) = Application.Transpose(a) 'fonction limitée à 65536 lignes
        .Offset(n).Resize(Rows.Count - n - .Row + 1, 4).ClearContents 'RAZ en dessous
    End With
    .Columns.AutoFit 'ajustement largeurs
End With
End Sub

Lorsque je le lance j'ai ce débogage en pièce jointe
POurtant ils sont bien tous dans le même répertoire

 

[job75]

Normalement cette ligne provoque un bug seulement si vous êtes sur MAC, c'est le cas ?

De toute façon c'est le fichier du post #15 qu'il faut utiliser.

 

[FCMLE44]

Normalement cette ligne provoque un bug seulement si vous êtes sur MAC, c'est le cas ?

Non c'est PC Windows 11

 

[job75]

Ce n'est pas normal, votre version Excel a de sérieux problèmes, essayez quand même ce fichier (3) avec :

Option Compare Text 'la casse est ignorée

Sub Importer()
Dim chemin$, fichier$, x%, montant As Boolean, texte$, civ, p%, n&, a(), deb%, fin%
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin) '1er fichier du dossier
While fichier <> ""
    If Right(fichier, 4) = ".txt" Then
        x = FreeFile
        Open chemin & fichier For Input As #x 'ouverture en lecture séquentielle
        montant = False
        While Not EOF(x)
            Line Input #x, texte
            texte = Replace(Replace(Replace(texte, "é", "é"), "è", "è"), "ê", "ê") 'épuration
            '---récupération du Montant à passer---
            If montant Then montant = False: If IsNumeric(texte) Then a(4, n) = CDbl(texte)
            '---nom---
            For Each civ In Array("Monsieur", "Madame", "Mademoiselle")
                p = InStr(texte, civ)
                If p Then
                    n = n + 1
                    ReDim Preserve a(1 To 4, 1 To n)
                    a(1, n) = fichier
                    deb = p + Len(civ)
                    fin = InStr(texte, "Arrêt")
                    If fin Then fin = fin - 1 Else fin = Len(texte)
                    a(3, n) = Trim(Mid(texte, deb, fin - deb + 1))
                    Exit For
                End If
            Next
            '---N°SS---
            p = InStr(texte, "SS :")
            If p Then
                deb = p + 4
                fin = Len(texte)
                a(2, n) = Trim(Mid(texte, deb, fin - deb + 1))
            End If
            '---Montant à passer---
            If texte = "Prestation complementaire" Then montant = True 'repérage
        Wend
        Close #x
    End If
    fichier = Dir 'fichier suivant
Wend
'---restitution---
With ActiveSheet 'à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A2]
        If n Then .Resize(n, 4) = Application.Transpose(a) 'fonction limitée à 65536 lignes
        .Offset(n).Resize(Rows.Count - n - .Row + 1, 4).ClearContents 'RAZ en dessous
    End With
    .Columns.AutoFit 'ajustement largeurs
End With
End Sub

 

[job75]

Bonjour FCMLE44, le forum,

La macro est faite pour Excel.

Si vous êtes sur SharePoint il est normal qu'elle ne fonctionne pas.

A+