XL 2010 cree plusieurs fichier txt à partir d'un tableau EXCEL

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
H

HASSAN19876

XLDnaute Nouveau
Bonjour ma demande est un peu compliqué je veux savoir si il y une manipulation pour crée des fichier txt un partir d'un tableau Excel
par exemple tableau ci-dessous je veux avoir sur un emplacement 4 ficheir TXT avec les noms de la 1 columne et à l'interieur de chaque ficheir les données de la 2 eme colaune :
nom fichierdonnée
karim 1
karim 2
karim 34
karim 57
karim 74
hassan 94
hassan 114
hassan 134
hassan 154
hassan 174
hassan 194
meriem 214
meriem 234
meriem 254
meriem 274
meriem 294
meriem 314
salah 334
salah 354
salah 374
salah 394
salah 414
 
Solution
job75
Pas de problème, fichier (2) :
VB: 
Sub CreerTXT()
Dim chemin$, P As Range, tablo, d As Object, i&
chemin = ThisWorkbook.Path & "\"
Set P = [A1].CurrentRegion.Resize(, 2)
tablo = P.Value 'matrice, plus rapide, au moins 2 éléments
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier a déjà été créé
With Workbooks.Add.Sheets(1) 'nouveau document
    For i = 2 To UBound(tablo)
        If tablo(i, 1) <> "" And Not d.exists(tablo(i, 1)) Then
            d(tablo(i, 1)) = ""
            .Columns(1).Clear
            .Cells(2, 3) = "=A2=""" & tablo(i, 1) & """" 'critère
            P.AdvancedFilter xlFilterCopy, .Cells(1...
Trier par date Trier par votes
Bonjour HASSAN19876, bienvenue sur XLD,

Voyez le fichier joint et cette macro qui utilise le filtre avancé :
VB: 
Sub CreerTXT()
Dim chemin$, P As Range, tablo, d As Object, i&
chemin = ThisWorkbook.Path & "\"
Set P = [A1].CurrentRegion.Resize(, 2)
tablo = P.Value 'matrice, plus rapide, au moins 2 éléments
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier a déjà été créé
With Workbooks.Add.Sheets(1) 'nouveau document
    For i = 2 To UBound(tablo)
        If tablo(i, 1) <> "" And Not d.exists(tablo(i, 1)) Then
            d(tablo(i, 1)) = ""
            .Columns(1).Clear
            .Cells(2, 3) = "=A2=""" & tablo(i, 1) & """" 'critère
            P.AdvancedFilter xlFilterCopy, .Cells(1, 3).Resize(2), .Cells(1) 'filtre avancé
            .Cells(2, 3) = ""
            .Columns(1).Delete
            .Parent.SaveAs chemin & tablo(i, 1), xlText
        End If
    Next
    .Parent.Close
End With
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
End Sub
A+
 

Pièces jointes

Vote positif 0 Vote négatif
Pas de problème, fichier (2) :
VB: 
Sub CreerTXT()
Dim chemin$, P As Range, tablo, d As Object, i&
chemin = ThisWorkbook.Path & "\"
Set P = [A1].CurrentRegion.Resize(, 2)
tablo = P.Value 'matrice, plus rapide, au moins 2 éléments
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier a déjà été créé
With Workbooks.Add.Sheets(1) 'nouveau document
    For i = 2 To UBound(tablo)
        If tablo(i, 1) <> "" And Not d.exists(tablo(i, 1)) Then
            d(tablo(i, 1)) = ""
            .Columns(1).Clear
            .Cells(2, 3) = "=A2=""" & tablo(i, 1) & """" 'critère
            P.AdvancedFilter xlFilterCopy, .Cells(1, 3).Resize(2), .Cells(1) 'filtre avancé
            .Cells(2, 3) = ""
            .Columns(1).Delete
            .Cells(1).Delete xlUp 'retire l'en-tête
            .Parent.SaveAs chemin & tablo(i, 1), xlText
        End If
    Next
    .Parent.Close
End With
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
End Sub
 

Pièces jointes

Vote positif 0 Vote négatif
Solution
Bonjour Job75,
ta macro m'intéresse et je la trouve vraiment géniale.
Pourrais tu stp me dire comment récupérer le fichier texte tel qu'il c'est à dire sans les guillemets ("xxxx")? en fait j 'ai exactement la même demande sauf que moi j'ai du texte à la place des chiffres. Du coup, quand je fais tourner la macro, j'ai les guillemets en plus dans mes fichiers texte.
Merci d'avance pour ton aide
crdlmt
 
Vote positif 0 Vote négatif
RebonjourJob75,
Merci de ton retour rapide.
J'ai testé les 2 fichiers Excel cités ci dessous (TXT1 et TXT2), les deux me renvoient des guillemets de ce type ("texte dans la cellule"). De plus, quand j'ai un texte contenant les guillemets, la macro les double. Exp : texte . copier dans la cellule : toto "toto bis""balala--> voici le texte récupéré dans le fichier texte : " toto ""toto bis""""balala"
J'aimerais juste récupéré le texte tel qu'il est
Merci encore une fois de ton aide
A+
 
Vote positif 0 Vote négatif
job75 à dit:
Mettez ce code avant la ligne du SaveAs.
Cliquez pour agrandir...
ça me supprime les guillemets que j'aimerais gardé ( à l'intérieur de mon texte) mais pas ceux des extrémités et je pense que c'est parce que j'ai 2 ou plusieurs ligne de texte dans ma cellule. Exp en PJ. en Fait le but c'est si possible est de récupérer le texte tel qu'il est.
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Bonjour bnolwalid,

En VBA il est rare qu'il n'y ait pas de solution, votre fichier en retour avec cette macro :
VB: 
Sub CreerTXT()
Dim chemin$, P As Range, tablo, d As Object, i&, tablo1, x%, j&
chemin = ThisWorkbook.Path & "\"
Set P = [A1].CurrentRegion.Resize(, 2)
tablo = P.Value 'matrice, plus rapide, au moins 2 éléments
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
With Workbooks.Add.Sheets(1) 'nouveau document
    For i = 2 To UBound(tablo)
        If tablo(i, 1) <> "" And Not d.exists(tablo(i, 1)) Then
            d(tablo(i, 1)) = ""
            .Columns(1).Resize(, 2).Clear
            .Cells(2, 3) = "=A2=""" & tablo(i, 1) & """" 'critère
            P.AdvancedFilter xlFilterCopy, .Cells(1, 3).Resize(2), .Cells(1) 'filtre avancé
            tablo1 = .UsedRange.Resize(, 2)
            x = FreeFile
            Open chemin & tablo(i, 1) & ".txt" For Output As #x 'ouverture en écriture séquentielle
            For j = 2 To UBound(tablo1)
                Print #x, tablo(j, 2)
            Next j
            Close #x
        End If
    Next i
    .Parent.Close False
End With
End Sub
A+
 

Pièces jointes

Vote positif 0 Vote négatif
job75 à dit:
Bonjour bnolwalid,

En VBA il est rare qu'il n'y ait pas de solution, votre fichier en retour avec cette macro :
VB: 
Sub CreerTXT()
Dim chemin$, P As Range, tablo, d As Object, i&, tablo1, x%, j&
chemin = ThisWorkbook.Path & "\"
Set P = [A1].CurrentRegion.Resize(, 2)
tablo = P.Value 'matrice, plus rapide, au moins 2 éléments
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
With Workbooks.Add.Sheets(1) 'nouveau document
    For i = 2 To UBound(tablo)
        If tablo(i, 1) <> "" And Not d.exists(tablo(i, 1)) Then
            d(tablo(i, 1)) = ""
            .Columns(1).Resize(, 2).Clear
            .Cells(2, 3) = "=A2=""" & tablo(i, 1) & """" 'critère
            P.AdvancedFilter xlFilterCopy, .Cells(1, 3).Resize(2), .Cells(1) 'filtre avancé
            tablo1 = .UsedRange.Resize(, 2)
            x = FreeFile
            Open chemin & tablo(i, 1) & ".txt" For Output As #x 'ouverture en écriture séquentielle
            For j = 2 To UBound(tablo1)
                Print #x, tablo(j, 2)
            Next j
            Close #x
        End If
    Next i
    .Parent.Close False
End With
End Sub
A+
Cliquez pour agrandir...
Bonjour Job75,

Je confirme ce qui a été dit ci dessus, vous êtes un GENIE.
ça fonctionne parfaitement .
Merci pour le support.
Très bonne journée.
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

G
  • Question Question
Améliorer et simplifier macro
2
Réponses
17
Affichages
3 K
ERIC S
ERIC S
Retour