Microsoft 365 Création fichier texte

[Mike89]

Bonjour à tous,

Je cherche à créer un fichier texte selon l'intitulé de la colonne A et donc y intégrer toutes les lignes contenant le même intitulé. La macro fonctionne cependant il y a un problème lors de la création du dernier fichier.

Ci-dessous le code :

Sub CréationTXT()
Dim dLig As Long, Lig As Long, LigSu As Long
Dim NumFic As Long, sDos As String
' Dossier de destination
sDos = ThisWorkbook.Path & "\"
' Numéro de fichier
NumFic = FreeFile
With ThisWorkbook.Sheets(1)
' Dernière ligne remplie de la colonne
dLig = .Range("A" & Rows.Count).End(xlUp).Row
' Pour chaque ligne
i = 1
LigSu = Lig + 1
For Lig = i To dLig
' Créer le fichier
Open sDos & .Range("A" & Lig) & ".txt" For Output As #NumFic
Do While Range("A" & LigSu) = Range("A" & Lig)
' Inscrire la valeur dedans
Print #NumFic, .Range("B" & Lig).Value & vbNewLine;
Lig = Lig + 1
LigSu = Lig + 1
Loop
Print #NumFic, .Range("B" & Lig).Value
' Fermer le fichier
Close #NumFic
Next Lig
End With
End Sub

Merci d'avance pour votre aide

cdlt,
Mike89

 

[Dranreb]

Bonsoir.
Les contrôles de rupture de séquence sont toujours délicats à programmer. C'est pourquoi j'ai écrit une fonction Gigogne qui les effectue tous en amont et range le résultat dans une collection d'éléments possédant une Id As Variant et une Co As Collection. Il ne reste plus qu'à écrire des For Each In imbriqués pour explorer la collection. Sinon c'est toujours galère pour ne pas louper le premier ou le dernier de chaque niveau. Voulez vous que j'en équipe votre classeur ?

Bon, je l'ai fait de toute façon, alors je le joins.

 

[dysorthographie]

Bonsoir,

Sub CréationTXT()
Dim I As Integer
With ThisWorkbook.Sheets(1).Range("A1").CurrentRegion
    For I = 1 To .Rows.Count
        AppendTxt ThisWorkbook.Path & "\" & .Cells(I, "A") & ".txt", .Cells(I, "B") & vbCrLf
    Next
End With
End Sub
Function AppendTxt(sFile, sText)
With CreateObject("Scripting.FileSystemObject")
    With .OpenTextFile(sFile, 8, True)
        .Write sText
        .Close
    End With
End With
End Function

 

[patricktoulon]

bonsoir
on peut prendre les choses simplement
d"ans une boucle
si variable old est différent de la cells(ligne,a) on print texte et ferme un fichier si un X ouvert et on en ouvre un nouveau
en sortie de boucle on print le dernier et on le ferme
de cette façon on ouvre une seule fois chaque fichier pour y inscrire la totalité pas besoin de passer en mode append
le code est très simple
et bien sur tout cela sans FSO

Sub CréationTXT()
    Dim x&, i&, texte$, Fichier$, OlD$
    With Feuil1.Range("A:B").Resize(Feuil1.Cells(Rows.Count, "A").End(xlUp).Row, 2)
        For i = 1 To .Rows.Count
            If OlD <> .Cells(i, 1) Then
                If x <> 0 Then Print #x, texte: Close #x: x = 0
                Fichier = ThisWorkbook.Path & "\" & .Cells(i, 1).Text & ".txt"
                x = FreeFile
                Open Fichier For Output As #x
                texte = .Cells(i, 2).Text & vbNewLine
                OlD = .Cells(i, 1).Text
            Else
                texte = texte & .Cells(i, 2).Text & vbNewLine
            End If
        Next
    End With
    'on print le dernier et on le ferme
    If x <> 0 Then Print #x, texte: Close #x

End Sub

terminé

 

[job75]

Bonsoir à tous,

J'y vais de ma solution, très simple et très classique :

Sub CreerTXT()
Dim chemin$, tablo, ub&, i&, x%, nomfich$, j&
chemin = ThisWorkbook.Path & "\"
tablo = [A1].CurrentRegion.Resize(, 3) '3ème colonne pour le repèrage
ub = UBound(tablo)
For i = 1 To ub
    If tablo(i, 3) = "" Then
        x = FreeFile
        nomfich = tablo(i, 1)
        Open chemin & nomfich & ".txt" For Output As #x 'ouverture en écriture séquentielle
        For j = i To ub
            If tablo(j, 1) = nomfich Then
                tablo(j, 3) = 1 'repère
                Print #x, tablo(j, 2) 'écriture
            End If
        Next j
        Close #x
    End If
Next i
End Sub

Il n'y a aucun problème de repérage.

Bonne nuit.

 

[patricktoulon]

re
@job75 oui aussi
mais je le fait en une seule boucle

 

[job75]

J'ai testé en recopiant le tableau A1:B13 sur 130 000 lignes, chez moi sur Win 11 Excel 2019 :

- macro du post #4 (Patrick) => 14,5 secondes

- ma macro du post #5 => 0,6 seconde.

 

[job75]

Dans les mêmes conditions la macro du post #3 de Robert s'exécute en 130 secondes.

 

[patricktoulon]

@job75
ok j'avoue c'est étonnant
on peut lui faire gagner encore un peu en jumpant( j-i )dans la boucle i

Sub CreerTXT2()
    Dim chemin$, tablo, ub&, i&, x%, nomfich$, j&,saute&
    chemin = ThisWorkbook.Path & "\"
    tablo = [A1].CurrentRegion.Resize(, 3)    '3ème colonne pour le repèrage
    ub = UBound(tablo)
    saute = 0
    For i = 1 + saute To ub
        If tablo(i, 3) = "" Then
            x = FreeFile
            nomfich = tablo(i, 1)
            Open chemin & nomfich & ".txt" For Output As #x    'ouverture en écriture séquentielle
            For j = i To ub
                If tablo(j, 1) = nomfich Then
                    tablo(j, 3) = 1    'repère
                    Print #x, tablo(j, 2)    'écriture
                saute = (j - i) - 1
                End If
            Next j
            Close #x
        End If
        
    Next i
End Sub

 

[patricktoulon]

re erreur
plutot comme ça

Sub CreerTXT2()
    Dim chemin$, tablo, ub&, i&, x%, nomfich$, j&
    chemin = ThisWorkbook.Path & "\"
    tablo = [A1].CurrentRegion.Resize(, 3)    '3ème colonne pour le repèrage
    ub = UBound(tablo)
    saute = 0
    For i = 1 + saute To ub
        If tablo(i, 3) = "" Then
            x = FreeFile
            nomfich = tablo(i, 1)
            Open chemin & nomfich & ".txt" For Output As #x    'ouverture en écriture séquentielle
            For j = i To ub
                If tablo(j, 1) = nomfich Then
                    tablo(j, 3) = 1    'repère
                    Print #x, tablo(j, 2)    'écriture
                saute = saute + 1
                End If
            Next j
            Close #x
        End If
        
    Next i
End Sub

 

[job75]

Bonjour le forum,

Ouh là Patrick, l'expression For i = 1 + saute To ub n'est exécutée qu'une fois, comme toute boucle !

Tu peux le vérifier en exécutant la macro en pas à pas, c'est classique.

Donc ta variable saute ne sert à rien.

Par contre on peut se passer de la 3ème colonne avec un repérage par effacement :

Sub CreerTXT()
Dim chemin$, tablo, ub&, i&, x%, nomfich$, j&
chemin = ThisWorkbook.Path & "\"
tablo = [A1].CurrentRegion.Resize(, 2)
ub = UBound(tablo)
For i = 1 To ub
    If tablo(i, 2) <> "" Then
        x = FreeFile
        nomfich = tablo(i, 1)
        Open chemin & nomfich & ".txt" For Output As #x 'ouverture en écriture séquentielle
        For j = i To ub
            If tablo(j, 1) = nomfich Then
                Print #x, tablo(j, 2) 'écriture
                tablo(j, 2) = "" 'repèrage par effacement
            End If
        Next j
        Close #x
    End If
Next i
End Sub

Mais sur 130 000 lignes la durée d'exécution reste inchangée à 0,6 seconde.

A+

 

[Dranreb]

Bonjour.
Sans ma fonction Gigogne qui simplifie la programmation applicative (la complexité de la programmation de service n'ayant à mes yeux aucune importance) je l'aurais écrit comme ça :

Sub CréationTXT()
   Dim sDos As String, TDon(), L As Long
   sDos = ThisWorkbook.Path & "\"
   TDon = ThisWorkbook.Sheets(1).[A1].CurrentRegion.Value
   L = 1
   Do
      Open sDos & TDon(L, 1) & ".txt" For Output As #1
      Do
         Print #1, TDon(L, 2)
         L = L + 1: If L > UBound(TDon, 1) Then Exit Do
         Loop Until TDon(L, 1) <> TDon(L - 1, 1)
      Close #1
      Loop Until L > UBound(TDon, 1)
   End Sub

 

[job75]

Bonjour Bernard,

Sur 130 000 lignes ta dernière macro s'exécute en 6,3 secondes chez moi.

A+

 

[patricktoulon]

re

Ouh là Patrick, l'expression For i = 1 + saute To ub n'est exécutée qu'une fois, comme toute boucle !

Ouh là @job75 bonjour bonjour
j'ai du mal le placer alors
la boucle i tourne ub fois
regarde exemple
teste ça une fois et reteste en débloquant la ligne ou je jump de 1 sur i a chaque fois que j'arrive a i+50 sur j

Sub test()
    For i = 1 To 100
        a = a + 1
        bi = bi + 1
        For j = i To 100

            'If j = i + 50 Then i = i + 1

            bj = bj + 1
        Next
    Next
    texte = texte & bi & " tour de boucle i" & vbCrLf
    texte = texte & bj & " tour de boucle J" & vbCrLf
    MsgBox texte

End Sub

non non la boucle i tourne bien ub fois -les eventuels jump

 

[job75]

Tu as mal regardé le pas à pas.

La boucle tourne ub fois mais l'instruction For i = 1 + saute To ub n'est lue et exécutée qu'une fois,

Comme pour toutes les boucles.