generer un fichier txt

amocco

XLDnaute Occasionnel
bonjour ,
je recois un fichier xls tous les jours avec en gros 3000 lignes . je voudrais tranferer certaines infos vers un fichier .txt de facon à pouvoir l'inserer manuellement dans une base mysql
j ai expliqué dans le fichier
merci pour votre aide .
 

Pièces jointes

  • donnees.xls
    27.5 KB · Affichages: 44

Lone-wolf

XLDnaute Barbatruc
Bonjour amocco

Un exemple parmi d'autres

VB:
Sub Copy_Txt()
Dim fs As Object, file As Object
Dim i As Integer, lig As Long
Dim line1, line2, line3, line4, line5

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set file = fs.CreateTextFile("D:\Main.txt", True)
    With Feuil1
        lig = .Cells(Rows.Count, "A").End(xlUp).Row
        For i = 5 To lig
            line1 = .Cells(i, "D")
            line2 = .Cells(i, "B")
            line3 = .Cells(i, "O")
            line4 = .Cells(i, "K")
            line5 = .Cells(i, "M")
            file.WriteLine line1
            file.WriteLine line2
            file.WriteLine line3
            file.WriteLine line4
            file.WriteLine line5
        Next
        i = i + 1
    End With
    file.Close
End Sub

Seulement dans SELECT il faut mettre le nom et le prénom ensemble et non séparé.
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour amocco, salut Lone-wolf,

Bien d'accord avec toi, si on sépare nom et prénom comment faire pour DE SAINT MAUR JEAN MICHEL ?

Par contre il est plus logique de déclarer la variable i comme la variable lig (As Long).

Et a priori l'instruction i = i + 1 ne sert à rien.

Enfin pourquoi le lecteur D:\ ? Ceci irait mieux je pense :
Code:
Set file = fs.CreateTextFile(ThisWorkbook.Path & "\Main.txt", True)
A+
 

job75

XLDnaute Barbatruc
Re,

Cela dit s'il y a toujours des traits d'union dans les noms et prénoms composés :
Code:
Sub Copy_Txt()
Dim fs As Object, file As Object
Dim i&, j%, line1, line2, line3, line4, line5
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set file = fs.CreateTextFile(ThisWorkbook.Path & "\Main.txt", True)
    With Feuil1
        For i = 5 To .Cells(Rows.Count, "A").End(xlUp).Row
            line1 = .Cells(i, "D")
            j = InStr(.Cells(i, "B"), " ")
            If j = 0 Then j = Len(.Cells(i, "B")) + 1
            line2 = Left(.Cells(i, "B"), j - 1)
            line3 = Mid(.Cells(i, "B"), j + 1)
            line4 = .Cells(i, "O")
            line5 = .Cells(i, "K")
            line6 = .Cells(i, "M")
            file.WriteLine line1
            file.WriteLine line2
            file.WriteLine line3
            file.WriteLine line4
            file.WriteLine line5
            file.WriteLine line6
        Next
    End With
    file.Close
End Sub
Testé sur une feuille source de 3000 lignes, chez moi la macro s'exécute en 0,30 seconde.

A+
 

job75

XLDnaute Barbatruc
Re, bonjour Pierre,
Testé sur une feuille source de 3000 lignes, chez moi la macro s'exécute en 0,30 seconde.
Avec un tableau VBA c'est plus rapide => 0,21 seconde :
Code:
Sub Copy_Txt()
Dim fs As Object, file As Object, t, i&, j%
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set file = fs.CreateTextFile(ThisWorkbook.Path & "\Main.txt", True)
    t = Feuil1.[A5].CurrentRegion.Resize(, 15) 'matrice, plus rapide
    For i = 1 To UBound(t)
        file.WriteLine t(i, 4)
        j = InStr(t(i, 2), " ")
        If j = 0 Then j = Len(t(i, 2)) + 1
        file.WriteLine Left(t(i, 2), j - 1)
        file.WriteLine Mid(t(i, 2), j + 1)
        file.WriteLine t(i, 15)
        file.WriteLine t(i, 11)
        file.WriteLine t(i, 13)
    Next
    file.Close
End Sub
Mais Pierre a raison, la création d'un fichier texte n'est pas indispensable.

A+
 

job75

XLDnaute Barbatruc
Re,

Au fait amocco, vous êtes sûr qu'il vous faut passer par MySQL ?

Sinon voyez le fichier joint avec 2 méthodes de copie des données :
Code:
Dim Tmem() 'variable tableau mémorisée pour être utilisée ultérieurement si nécessaire

Sub Extraire()
Dim t, i&, j%
    t = Feuil1.[A5].CurrentRegion.Resize(, 15) 'matrice, plus rapide
    ReDim Tmem(1 To UBound(t), 1 To 6) 'RAZ
    For i = 1 To UBound(t)
        j = InStr(t(i, 2), " ")
        If j = 0 Then j = Len(t(i, 2)) + 1
        Tmem(i, 1) = t(i, 4)
        Tmem(i, 2) = Left(t(i, 2), j - 1)
        Tmem(i, 3) = Mid(t(i, 2), j + 1)
        Tmem(i, 4) = t(i, 15)
        Tmem(i, 5) = t(i, 11)
        Tmem(i, 6) = t(i, 13)
    Next
End Sub

Sub Copie1()
    Extraire
    Application.ScreenUpdating = False
    With Workbooks.Add.Sheets(1) 'nouveau classeur
        .[A2].Resize(UBound(Tmem), 6) = Tmem
        .[A1].Resize(, 6) = [{"Sign","Nom","Prénom","Téléphone","Cat","Qual"}]
        .Rows(1).Font.Bold = True 'gras
        .Columns.AutoFit 'ajustement largeur
        'au besoin enregistrer et fermer le classeur
    End With
End Sub

Sub Copie2()
Dim source As Range
    Set source = Feuil1.[A5].CurrentRegion.Resize(, 15)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Workbooks.Add.Sheets(1) 'nouveau classeur
        source.Columns(4).Copy .[A2]
        source.Columns(2).Copy .[B2:C2] '2 colonnes de même formats
        .[B:B].TextToColumns .[B2], xlDelimited, Space:=True 'commande Convertir
        source.Columns(15).Copy .[D2]
        source.Columns(11).Copy .[E2]
        source.Columns(13).Copy .[F2]
        .[A1].Resize(, 6) = [{"Sign","Nom","Prénom","Téléphone","Cat","Qual"}]
        .Rows(1).Font.Bold = True 'gras
      .Columns.AutoFit 'ajustement largeur
      'au besoin enregistrer et fermer le classeur
    End With
End Sub
Chez moi Copie1 s'exécute en 0,22 seconde, Copie2 en 0,24 seconde.

A+
 

Pièces jointes

  • donnees(1).xls
    607 KB · Affichages: 30

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 915
Membres
101 837
dernier inscrit
Ugo