[XL-2003] Export de données excel avec largeur de colonne fixe

Export de données excel avec largeur de colonne fixe

Bonjour,

Je viens faire appel à votre aide concernant un problème d'exportation de fichier.

En effet j'utilise un classeur excel pour importer un fichier texte, je le retravaille automatiquement via une macro et maintenant je souhaite l'enregistrer en format texte mais en utilisant comme déliminateur les largeurs de colonne et non le séparateur ou la tabulation;

Voici le code pour l'importation :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
Sub Import_netlist()
 
    'Variable stockant le nom du classeur
    Dim nomClasseur As String
    nomClasseur = ActiveWorkbook.Name
 
    'Variable stockant le nom de la feuille où devront se trouver les données à importer
    Dim feuilImport As String
    feuilImport = "Netlist"
 
    'Variable stockant le nom du fichier à ouvrir
    Dim fichier As String
 
'Retour possible pour choisir de nouveau un fichier
choixFichierTexte:
    'Choix d'un fichier texte
    fichier = Application.GetOpenFilename("Netlist Files (*.nod), *.nod")
 
    'Si aucun fichier est choisi
    If Left(fichier, 4) = "Faux" Then
        GoTo pasDeFichierTexte
    End If
 
 
    Range("A1").Select
 
    'Enlève l'apparition de boîte de dialogue
    Application.DisplayAlerts = False
 
    'Déclaration de variable
    Dim fichier1 As String
 
    'Ajout d'un élément texte au nom du fichier pour pouvoir exécuter la requête sur le fichier texte de données
    fichier1 = "TEXT;" & fichier & ";"
 
    'Formatage des données pour une bonne insertion des données dans les cellules
    On Error GoTo ouvrirTexte
        With ActiveSheet.QueryTables.Add(Connection:=fichier1, Destination:=Range("A1"))
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 850
            .TextFileStartRow = 1
            .TextFileParseType = xlFixedWidth
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = True
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
            .TextFileFixedColumnWidths = Array(22, 20, 15, 10, 8, 12, 2, 4, 4)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
 
    Resume
 
retourouvrirTexte:
    'Sélection d'une cellule
    Range("A1").Select
 
    'Rétablit l'apparition de boîte de dialogue
    Application.DisplayAlerts = True
 
    'Avertissement pour l'utilisateur
    MsgBox "Les données textes ont été importées.", vbOKOnly & vbInformation, "Importation des données"
 
    Exit Sub
 
'Récupération de l'erreur de non sélection d'un fichier texte à ouvrir
pasDeFichierTexte:
 
    'Variables de d'avertissement de la non sélection du fichier texte
    Dim messageFichier As Integer
 
    'Boite de dialogue de lancement du traitement
    messageFichier = MsgBox("Vous n'avez pas sélectionner de fichier texte à ouvrir !" & Chr(10) & Chr(10) & "Voulez-vous importer des données de la banque HYDRO ?" & Chr(10) & Chr(10) & "Pour importer ces données, appuyez sur " & Chr(34) & "OK" & Chr(34) & ", pour l'interrompre sur " & Chr(34) & "Annuler" & Chr(34) & ".", 1 + 64 + 256, "Importation de données de la banque HYDRO")
 
    'Si "Annuler a été choisi, on interromp le traitement
    If messageFichier = 2 Then
        Exit Sub
    End If
 
    'Retour à la boîte de sélection de fichier texte
    GoTo choixFichierTexte
 
ouvrirTexte:
 
    'Variable stockant le nom du fichier
    Dim nomFichier As String
 
    'Variable compteur de lettre
    Dim lettre As Integer
 
    'Récupération du nom du fichier
    Do While Left(Right(fichier, lettre), 1) <> "\"
        nomFichier = Right(fichier, lettre)
        lettre = lettre + 1
    Loop
 
    'Ouverture du fichier texte par Excel avec la mise en forme nécessaire
    Workbooks.OpenText FileName:=fichier, Origin:=xlWindows, StartRow:=1, DataType:=xlFixedWidth, TextQualifier _
        :=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:= _
        False, Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array( _
        1, 1), Array(22, 1), Array(42, 1), Array(60, 1), Array(67, 1), Array(76, 1), Array(87, 1), Array(92, _
        1), Array(97, 1), Array(102, 1))
 
    'Sélection des données et copie
    Cells.Select
    Selection.Copy
 
    'Sélection du classeur, de la feuille et collage des données
   Workbooks(nomClasseur).Activate
    Worksheets(feuilImport).Select
    Cells.Select
    ActiveSheet.Paste
    Selection.ColumnWidth = 0.25
 
    'Fermeture du classeur intermédiaire
    Workbooks(nomFichier).Close
 
    'Retour au traitement des données
    GoTo retourouvrirTexte
 
End Sub

Je vous remercie pour votre aide :)

Bonjour

Je n'ai pas regardé tout ton code d'importation.

Voici un code générique qu'il te faudra adapter.

Déclarer des variables as string*25 réserve 25 caractères à la variable. Tu es certain ainsi de la largeur. L'exemple que j'ai mis "triture" une date pour expliquer une façon d'enregistrer une date en largeur fixe

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Sub ExporterLargeursFixes()
  Dim NomFichier As String
  Dim Cellule As Range
  Dim Donnee As String
 
  NomFichier = "d:\données\largeursfixes.txt"
 
  Dim Nom As String * 25, Prenom As String * 25, DateNaissance As String * 8, Sexe As String * 1
 
  Open NomFichier For Output As #1
 
  'Lignes d'entête
  Nom = "Nom"
  Prenom = "Prenom"
  DateNaissance = "DN"
  Sexe = "s"
  Donnee = Nom & Prenom & DateNaissance & Sexe
  Print #1, Donnee
 
  For Each Cellule In Range("a2:a50")
    Nom = Cellule
    Prenom = Cellule(1, 2)
    DateNaissance = Format(Cellule(1, 3), "yyyy") & Format(Cellule(1, 3), "mm") & Format(Cellule(1, 3), "dd")
    Sexe = Cellule(1, 4)
  Donnee = Nom & Prenom & DateNaissance & Sexe
  Print #1, Donnee
  Next Cellule
 
  Close #1
End Sub

Merci pour ton aide,

En fait j'ai trouvé la solution à mon problème.

Il fallait que j'utilise le format de sortie *.prn

Voici le code source

Code:

1
2
3
4
5
6
7
8
9
10
11
12
 
Sub Export()
' Declaration variables
    Dim FileName As String
 
'  Demande fichier de sauvegarde
    FileName = Application.GetSaveAsFilename("Netlist", "Text Files (*.txt), *.txt")
 
 ActiveWorkbook.SaveAs FileName:= _
        FileName, FileFormat:= _
        xlTextPrinter, CreateBackup:=False
End Sub