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

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
job75

job75

XLDnaute Barbatruc
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

  • Créer TXT(1).xlsm
    19.3 KB · Affichages: 13
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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

  • Créer TXT(2).xlsm
    19.5 KB · Affichages: 9
Vote positif 0 Vote négatif
Solution
B

bnolwalid

XLDnaute Junior
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
B

bnolwalid

XLDnaute Junior
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
B

bnolwalid

XLDnaute Junior
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

  • Créer TXT(3).xlsm
    20.1 KB · Affichages: 3
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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

  • Créer TXT(3).xlsm
    20.4 KB · Affichages: 5
Vote positif 0 Vote négatif
B

bnolwalid

XLDnaute Junior
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

Discussions similaires

L
  • Question
XL 2013 Aide VBA
Réponses
4
Affichages
1 K
LAC736
L
S
  • Question
Une erreur VBA très bizarre
Réponses
11
Affichages
2 K
solobomb
S
G
  • Question
Améliorer et simplifier macro
2
Réponses
17
Affichages
3 K
ERIC S
ERIC S

Membres actuellement en ligne

10 membres et 97 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 167
Messages
2 116 924
Membres
112 915
dernier inscrit
Ludof