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

job75 à dit:

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

VB:

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

Cliquez pour agrandir...

job75 à dit:

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

Cliquez pour agrandir...