XL 2013 Macro export vers .txt

Leché · 25 Janvier 2021

Bonjour,

Je souhaiterai mettre en place une macro permettant de faire ceci :

J’ai un fichier Excel nommée « FDS », dans ce fichier il y a plusieurs onglets dont :

Un onglet nommé « X »
Un onglet nommé « Y »

Pour ces deux onglets, je souhaiterai exporter dans deux fichiers .txt différents , (nommé de la même façon que les noms des onglets) l’ensemble des valeurs de la colonne F (A partir de la ligne 7 jusqu’à la dernière ligne non-vide)

Soit un fichier .txt nommé Y, reprenant l’ensemble des valeurs de la colonne F de l’onglet Y (à partir de la 7eme ligne)

Et un fichier .txt nommé X, reprenant l’ensemble des valeurs de la colonne F de l’onglet X (à partir de la 7eme ligne)

Cette macro sera lancée depuis un fichier Excel « vierge » (juste ouvert pour lancer la macro) ciblant donc le fichier excel « FDS » (qui sera dans le même dossier)
Les deux fichier .txt seront enregistrer dans le même fichier que FDS et le fichier vierge.

Si vous avez un bout de code pour commencer

Merci d'avance pour vos retour,

Bonne journée

dysorthographie · 26 Janvier 2021

VB:

Sub test()
With Workbooks.Open(ThisWorkbook.Path & "\FDS.xlsm")  'Ouvre le Fichier Source à voir
   FichierTxt .Sheets("30x2"), ThisWorkbook.Path & "\30x2.txt"
   FichierTxt .Sheets("35x2"), ThisWorkbook.Path & "\35x2.txt"
   .Close
End With
End Sub
Sub FichierTxt(Onglet As Worksheet, Txt As String)
Dim F As Long
F = FreeFile
  With Onglet
    Enrgt = ""
    For Each C In .Range("F7", .Cells(.Rows.Count, "F").End(xlUp))
     If Not C.EntireRow.Hidden And CStr(C) <> "" Then
        If Enrgt <> "" Then Enrgt = Enrgt & vbCrLf
            Enrgt = Enrgt & C.Value
            End If
    Next C
  End With
Open Txt For Append As #F
    Print #F, Enrgt
Close #F
End Sub

ChTi160 · 26 Janvier 2021

Re oui j'ai vu d'où le rajout dans #58

dysorthographie · 26 Janvier 2021

patricktoulon à dit:
perso je dis que le trop c'est comme le pas assez (quand c'est trop on sais plus quoi en faire)
alors que si on respecte le " fait comme ça doit être fait" la réponse t'a été donné en page 1 par ~~Robert~~
j'imagine le débutant qui viens de faire connaissance avec excel vba
purée de manon!!!!se taper 4 pages pour au final ne pas savoir ce qui est vraiment propre ou pas
purée je suis sur celui là retourne sur une game boy

LOL
allez salut les artistes

rendons à danielco ce qui est à danielco!

patricktoulon · 26 Janvier 2021

re

Bonjour à Patrick ! Toujours aussi pressé Lol

bonjour @ChTi160 non pas du tout au contraire même j'ai suivi de loin
mais quand c'est absurde ça peut être rigolo mais trop absurde ça reste absurde
moi ce qui me fait marrer c'est que maintenant on a le message 1(la demande) en top de page (quelque soit la page)
autrement dit plus d'excuses le sujet ne se perd plus au fil des pages

Si vous avez un bout de code pour commencer

heu.. je me marre

patricktoulon · 26 Janvier 2021

Bonjour,

Je souhaiterai mettre en place une macro permettant de faire ceci :

J’ai un fichier Excel nommée « FDS », dans ce fichier il y a plusieurs onglets dont :

Un onglet nommé « X »

Un onglet nommé « Y »

Pour ces deux onglets, je souhaiterai exporter dans deux fichiers .txt différents , (nommé de la même façon que les noms des onglets) l’ensemble des valeurs de la colonne F (A partir de la ligne 7 jusqu’à la dernière ligne non-vide)

Soit un fichier .txt nommé Y, reprenant l’ensemble des valeurs de la colonne F de l’onglet Y (à partir de la 7eme ligne)

Et un fichier .txt nommé X, reprenant l’ensemble des valeurs de la colonne F de l’onglet X (à partir de la 7eme ligne)

Cette macro sera lancée depuis un fichier Excel « vierge » (juste ouvert pour lancer la macro) ciblant donc le fichier excel « FDS » (qui sera dans le même dossier)
Les deux fichier .txt seront enregistrer dans le même fichier que FDS et le fichier vierge.

Si vous avez un bout de code pour commencer

Merci d'avance pour vos retour,

Bonne journée

ouais ok
j'en rajoute une couche

VB:

Sub test()
    Dim Wbk As Workbook, tbl(1 To 2), NM, i&, x&,chemin$
    chemin = ThisWorkbook.Path & "\"
    Set Wbk = Workbooks.Open(chemin & "FDS.xlsx")
    NM = Array("Feuil1", "feuil2")    'arranger les noms des feuilles
    tbl(1) = Application.Index(Wbk.Sheets(NM(0)).Range("F7", Wbk.Sheets(NM(0)).Cells(Rows.Count, "F").End(xlUp)).Value, 0, 1)
    tbl(2) = Application.Index(Wbk.Sheets(NM(1)).Range("F7", Wbk.Sheets(NM(1)).Cells(Rows.Count, "F").End(xlUp)).Value, 0, 1)
    For i = 0 To UBound(NM)
        x = FreeFile
        Open chemin & NM(i) & ".txt" For Output As #x: Print #x, Join(tbl(i + 1), vbCrLf): Close #x
    Next i
wbk.close
End Sub

job75 · 26 Janvier 2021

Bonjour à tous,

Je ne comprends vraiment pas que sur un problème aussi simple on en soit à 65 posts !!!

En tout cas pour le problème posé au post #1.

Téléchargez les fichiers joints dans le même dossier et exécutez la macro du bouton :

VB:

Sub Fichiers_TXT()
Dim chemin$, w As Worksheet, P As Range, tablo
chemin = ThisWorkbook.Path & "\" 'à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier est déjà créé
With Workbooks.Open(chemin & "FDS.xlsx") 'nom du fichier à adapter
    For Each w In .Sheets(Array("X", "Y")) 'noms des feuilles à adapter
        w.Activate 'activation nécessaire
        If w.FilterMode Then w.ShowAllData 'si la feuille est filtrée
        Set P = Intersect(w.Columns(6), w.Range("F7:F" & w.Rows.Count), w.UsedRange)
        If Not P Is Nothing Then
            tablo = P.Resize(, 2) 'mémorise les valeurs, au moins 2 éléments
            w.Cells.Delete 'RAZ
            w.Cells(1).Resize(UBound(tablo)) = tablo 'restitution
            .SaveAs chemin & w.Name, xlText 'fichier .txt
        End If
    Next
    .Close False
End With
End Sub

A+

patricktoulon · 26 Janvier 2021

re
ouais!!! c'est vrai ça !!!!!!

ChTi160 · 26 Janvier 2021

Re
ca vous etonne qu'il y ai autant de pages, comme dirait Patrick.
la réponse est en page 1
Patrick j'ai testé ton Code du Post #64 et j'ai un message d'erreur "Erreur d'exécution 5"
sur

VB:

Join(tbl(i + 1), vbCrLf)

jean marie

job75 · 26 Janvier 2021

Il vaut mieux ce fichier (2) si l'une des feuilles "X" ou "Y" est vide :

VB:

Sub Fichiers_TXT()
Dim chemin$, w As Worksheet, P As Range, tablo
chemin = ThisWorkbook.Path & "\" 'à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier est déjà créé
With Workbooks.Open(chemin & "FDS.xlsx") 'nom du fichier à adapter
    For Each w In .Sheets(Array("X", "Y")) 'noms des feuilles à adapter
        w.Activate 'activation nécessaire
        If w.FilterMode Then w.ShowAllData 'si la feuille est filtrée
        Set P = Intersect(w.Columns(6), w.Range("F7:F" & w.Rows.Count), w.UsedRange)
        If Not P Is Nothing Then
            tablo = P.Resize(, 2) 'mémorise les valeurs, au moins 2 éléments
            w.Cells.Delete 'RAZ
            w.Cells(1).Resize(UBound(tablo)) = tablo 'restitution
        Else
            w.Cells.Delete 'RAZ
        End If
        .SaveAs chemin & w.Name, xlText 'fichier .txt
    Next
    .Close
End With
End Sub

patricktoulon · 26 Janvier 2021

re
pardon autant pour moi @ChTi160 il faut transposer
avec tout ça je fait des co......es

VB:

Sub test()
    Dim Wbk As Workbook, tbl(1 To 2), NM, i&, x&,chemin$
    chemin = ThisWorkbook.Path & "\"
    Set Wbk = Workbooks.Open(chemin & "FDS.xlsx")
    NM = Array("Feuil1", "feuil2")    'arranger les noms des feuilles
    tbl(1) = Application.transpose(Application.Index(Wbk.Sheets(NM(0)).Range("F7", Wbk.Sheets(NM(0)).Cells(Rows.Count, "F").End(xlUp)).Value, 0, 1))
    tbl(2) = Application.transpose(Application.Index(Wbk.Sheets(NM(1)).Range("F7", Wbk.Sheets(NM(1)).Cells(Rows.Count, "F").End(xlUp)).Value, 0, 1))
    For i = 0 To UBound(NM)
        x = FreeFile
        Open chemin & NM(i) & ".txt" For Output As #x: Print #x, Join(tbl(i + 1), vbCrLf): Close #x
    Next i
wbk.close
End Sub

ChTi160 · 26 Janvier 2021

Re
Arff après on dit pourquoi faire Compliqué quand on peut faire simple Lol
Dans le Post de Job75 #68 comme celui de Patrick #69
je ne vois pas ou l'on tient compte des cellules Vide Ou masquées qu'il ne faut pas transférer !
Mais on va m'expliquer Lol
Merci Patrick !
jean marie

patricktoulon · 26 Janvier 2021

re
oui je sais pas peut être que "lignes vides" a été une condition supplémentaire évoquée par le demandeur
entre la page 1 et 5
@job75 répond correctement a la question de base avec sa méthode
LOL

dysorthographie · 26 Janvier 2021

Oui le demandeur à souhaité évincer les lignes vide ainsi que les lignes Hidden

ChTi160 · 26 Janvier 2021

Re
il dit :

Mince, j'ai des cellules qui sont masqués (il y a un filtre) elles sont donc directement copiés avec les valeurs visibles, peut t-on les cachés elles aussi ?

c'est en feuille 3
on en rajoute une couche ? Lol
jean marie

job75 · 26 Janvier 2021

dysorthographie à dit:
Oui le demandeur à souhaité évincer les lignes vide ainsi que les lignes Hidden

Alors on rajoute une couche, utilisez ce fichier (3) :

VB:

Sub Fichiers_TXT()
Dim chemin$, w As Worksheet, P As Range, tablo
chemin = ThisWorkbook.Path & "\" 'à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier est déjà créé
On Error Resume Next
With Workbooks.Open(chemin & "FDS.xlsx") 'nom du fichier à adapter
    Workbooks.Add 'document auxiliaire vierge
    For Each w In .Sheets(Array("X", "Y")) 'noms des feuilles à adapter
        w.Rows("1:6").Hidden = True
        With Intersect(w.Columns(6), w.UsedRange)
            .SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True 'masque les cellules vides
            .Copy
        End With
        [A1].PasteSpecial xlPasteValues 'collage spécial-Valeurs
        Application.CutCopyMode = 0
        ActiveWorkbook.SaveAs chemin & w.Name, xlText 'fichier .txt
        Cells.Clear 'RAZ
    Next
    ActiveWorkbook.Close False
    .Close False
End With
End Sub

XL 2013 Macro export vers .txt

Leché

XLDnaute Junior

dysorthographie

ChTi160

XLDnaute Barbatruc

dysorthographie

XLDnaute Accro

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

ChTi160

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

ChTi160

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

dysorthographie

XLDnaute Accro

ChTi160

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

Discussions similaires