VBA Extraction et affichage de données sous EXCEL

Version imprimable

3 pièce(s) jointe(s)

Bonjour;

Avant de vous poser mon problème , je tenais a vous remercier d'avance pour votre participation .

voici mon probleme:
Je dois réaliser des macros qui me permettraient d'extraire des données à partir des fichiers Qstat format text.

J'ai deux fonctions que je voulais adapter pour pouvoir faire l'extraction
(fonctions permettant d'acceder aux fichiers (sélections multiples) et d'afficher leurs données les unes aprés les autres sur une seule même feuille d'excel "concaténation des données").

-1ere fonction fait exactement le travail que je veux mais seulement avec un seul fichier séléctionné :cry:

-2eme fonction permet de faire une sélection de plusieurs fichiers et d'extraire leur données les unes aprés les autres (concaténation ) sur une même feuille excel

NB: Je veux adapter la 1ere fonctiona la deuxième (Faire plusieurs sélections de fichiers et de les afficher sur ine même feuille d'excel en les concaténant)

Fonction1

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
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
 
'Fonction pour sélectionner le fichier Qstat à charger en Mémoire
Function select_fichier_Qstat() As String
'Déclaration des variables
Dim chemin As String
Dim intPosition As Integer
Dim strFichier As String
Dim msgErr As String
'variable pour contenir le chemin du fichier sélectionné.
Dim vrtSelectedItem As Variant
'variable objet FileDialog.
Dim fd As FileDialog
'Création d'un objet FileDialog comme une boîte de dialogue Fichier
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'Use a With End With block to reference the FileDialog object
With fd
    'Utilisation de la méthode Show pour afficher la boîte de dialogue Fichier Picker et retourner l'action
    If .Show = -1 Then
        'pour parcourir les etapes
        For Each vrtSelectedItem In .SelectedItems
            'vrtSelectedItem pour stocker le chemin de chaque élément sélectionné
            'et affichage du chemin d'accès dans la boîte de message
            MsgBox "le fichier choisi est: " & vrtSelectedItem
        Next vrtSelectedItem
        If .SelectedItems.Count = 1 Then
           chemin = fd.SelectedItems(1)
        End If
    End If
End With
'sortir de l'objet.
Set fd = Nothing
'recupére le chemin
select_fichier_Qstat = chemin
'Pour recupérer le nom du fichier Qstat
' On cherche dans chemin la position du caractère \ en partant de la fin
intPosition = InStrRev(chemin, "\")
'si le caractère n'a pas été trouvé
If intPosition = 0 Then
    strFichier = chemin
'si le caractère a été trouvé : on prend tout ce qui le suit
Else
    strFichier = Mid(chemin, intPosition + 1)
    'Pour enlever l'extension, on cherche le dernier point
    intPosition = InStrRev(strFichier, ".")
    'Si on le trouve, on ne garde que ce qui précède
    If intPosition <> 0 Then
        strFichier = Mid(strFichier, 1, intPosition - 1)
    End If
End If
'on affiche le nom
'ActiveSheet.Cells(54, 3) = strFichier
End Function
 
 
Sub QStat()
    Dim num1 As Integer
    Dim nim2 As Integer
    Dim diff As Integer
    Dim intFic As Integer
    Dim strLigne As String
    Dim detect As Boolean
    Dim strCount As String
    Dim Source As String
 
    'affectation du repertoire
    Source = Module2.select_fichier_Qstat
    'detect : Variable de controle de fichier
    detect = True
    intFic = FreeFile
    'ouverture du fichier
    Open Source For Input As intFic
    While Not EOF(intFic) And detect
        detect = False
        Line Input #intFic, strLigne
        If Left(strLigne, 3) = "EV|" Then
            'Controle sur le Event
                'Nbre |
                num1 = Len(strLigne)
                strCount = Replace(strLigne, "|", "")
                num2 = Len(strCount)
                diff = num1 - num2
                If diff = 35 Then
                    detect = True
                Else
                    MsgBox "Erreur - Le champ EV contient " & diff & " | au lieu de 35"
                    detect = False
                End If
        End If
        If Left(strLigne, 3) = "ME|" Then
            'Controle sur la mesure
                'Nbre |
                num1 = Len(strLigne)
                strCount = Replace(strLigne, "|", "")
                num2 = Len(strCount)
                diff = num1 - num2
                If diff = 19 Then
                    detect = True
                Else
                    MsgBox "Erreur - Le champ ME contient " & diff & " | au lieu de 19"
                    detect = False
                End If
        End If
        If Left(strLigne, 3) = "TD|" Then
            'Controle sur les limites
                'Nbre |
                num1 = Len(strLigne)
                strCount = Replace(strLigne, "|", "")
                num2 = Len(strCount)
                diff = num1 - num2
                If diff = 18 Then
                    detect = True
                Else
                    MsgBox "Erreur - Le champ EV contient " & diff & " | au lieu de 18"
                    detect = False
                End If
        End If
    Wend
    If detect = False Then
        MsgBox "Erreur - Une ou plusieurs lignes sont erronnées"
    Else
        MsgBox "Le Fichier Qstat est correct !!"
    End If
    Close intFic
 
    ' On passe à l'affichage
    Dim i As Integer
    Dim cpt As Integer
    Dim Tableau() As String
    i = 1
    cpt = 1
 
    If detect = True Then
        intFic = FreeFile
        Worksheets("Feuil1").Select
        'Entete
        Cells(5, 1) = "Pas de Test"
        Cells(6, 1) = "Données Numérique"
 
        'ouverture du fichier
        Open Source For Input As intFic
        While Not EOF(intFic)
            Line Input #intFic, strLigne
            If Left(strLigne, 3) = "ME|" Then
                'on incrémente la ligne d'ecriture
                i = i + 1
                'on decompose
                Tableau = Split(strLigne, "|")
                'on ecrit
                 Cells(5, i) = Tableau(4)
                Cells(6, i) = Tableau(6)
            End If
        Wend
    End If
End Sub

Fonction 2

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
Sub Fonction_concatenee()
Dim Fichiers As Variant
Dim i As Integer
Dim wb As Workbook
Dim donnees As Range
 
    Fichiers = Application.GetOpenFilename("Fichiers dat (*.txt), *.txt", , , , True)
 
    If IsArray(Fichiers) = True Then
 
        Application.ScreenUpdating = False
 
        For i = LBound(Fichiers) To UBound(Fichiers)
 
            Workbooks.OpenText Filename:=Fichiers(i), DataType:=xlDelimited, Tab:=True
            Set wb = ActiveWorkbook
            Set donnees = wb.Sheets(1).[A1].CurrentRegion
            donnees.Copy ThisWorkbook.Sheets(1).[A65536].End(xlUp)(2)
            wb.Close
            Set donnees = Nothing
            Set wb = Nothing
 
        Next i
 
        Application.ScreenUpdating = True
 
    End If
End Sub

fichiers Qstat

02/01/2014, 11h45
Marc-L

Bonjour.

Il y aurait plus de réponse en postant dans la bonne section Macros & VBA Excel …

Citation:

Envoyé par gibba88

-2eme fonction permet de faire une sélection de plusieurs fichiers et d'extraire leur données les unes aprés les autres (concaténation ) sur une même feuille excel

NB: Je veux adapter la 1ere fonctiona la deuxième (Faire plusieurs sélections de fichiers et de les afficher sur ine même feuille d'excel en les concaténant)

Comme c'est exprimé, ce que tu veux correspond déjà à la 2ème fonction ‼

Sinon sans présentation claire & exhaustive …
02/01/2014, 15h14
gibba88

Merci pour votre réponse , En faite comme je vous l'ai déja précisé , la 1ere fonction fais le travail que j'attends mais elle le fait seulement avec un seul fichier sélection .
Ce que je voudrais c'est une fonction qui me permettrait d'acceder aux fichiers avec une sélection multiples et de recupérerles les élements correspondants à la partie "ME" comme dans la fonction 1.En concaténant les données des fichiers les une aprés les autres.

NB: Contrairement à la 1ere, La 2eme fonction ne me permet pas de manupuler les fichiers:calim2:
02/01/2014, 15h30
Marc-L

Et pourtant la première fonction est déjà en multi-sélection ‼

Juste le traitement manquant au sein de la boucle For Each … Next des lignes n°20 à 24 …
06/01/2014, 14h03
gibba88

En faite quand j'éxécute "Qstat()" ,en choisissant un seul fichier on ne note pas d'erreurs mais dès l'instant qu'on choisit plusieurs fichiers à extraire, il nous met "Erreur d'acces au fichier" .Donc le probleme vient du nombre de fichiers à choisir. J'ai essayer de déclarer un tableau et de parcourir les fichiers en les ouvrant un par un mais il m'affiche toujour le meme probleme :cry:.

NB: je suis débutant en VBA
06/01/2014, 16h43
Marc-L

Dans la continuité de ma précédente remarque, la ligne n°33 de la Fonction1 est inutile
car chaque fichier du tableau est initialisé en ligne n°20.

Tout le traitement doit donc se situer entre les lignes n°20 & 24
en utilisant la variable de la ligne n°20 pour l'accès à chacun des fichiers sélectionnés …

1 pièce(s) jointe(s)

J'ai modifié ma fonction , maintenant j'arrive a faire une selection multiple et à verifier le format des fichiers . mais je rencontré un autre probleme car j'arrive pas à concaténer les données extraits des fichiers text sur excel. Le souci se trouve sur la partie affichage du code car j'arrive a charger plusieurs fichiers mais j'extrais au final les données d'un seul fichier.

PJ: Extraction finale attendue (exemple de fichier traité ,fait manuellement)

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
 
Sub Select_fichier_QStat()
    Dim fn As Variant
    Dim i&
    Dim TbFn$(), ff%, s$
    Dim num1 As Integer
    Dim nim2 As Integer
    Dim diff As Integer
    Dim detect As Boolean
    Dim strCount As String
    '-----------------------------------
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    'sélection des fichiers txt à traiter
    fn = Application.GetOpenFilename("Fichiers textes (*.txt), *.txt", , , , True)
    If TypeName(fn) = "Boolean" Then Exit Sub 'quitter si annuler
    'nouvelle feuille
    'Sheets.Add
    detect = True
    'fichiers à ouvrirs
    ReDim TbFn(1 To UBound(fn))
    'Traitement
    For i = 1 To UBound(fn)
        TbFn(i) = fn(i) 'fichier en cours
        ff = FreeFile
        Open TbFn(i) For Input As #ff 'ouverture
            Do Until EOF(ff) 'tant que fin du fichier non atteinte
                Line Input #ff, s 'lire une ligne
                If Left(s, 3) = "EV|" Then
                    'Controle sur le Event
                    'Nbre |
                    num1 = Len(s)
                    strCount = Replace(s, "|", "")
                    num2 = Len(strCount)
                    diff = num1 - num2
                    If diff = 35 Then
                        detect = True
                    Else
                        MsgBox "Erreur - Le champ EV contient " & diff & " | au lieu de 35"
                        detect = False
                    End If
                End If
                If Left(s, 3) = "ME|" Then
                    'Controle sur la mesure
                    'Nbre |
                     num1 = Len(s)
                     strCount = Replace(s, "|", "")
                     num2 = Len(strCount)
                     diff = num1 - num2
                     If diff = 19 Then
                        detect = True
                     Else
                        MsgBox "Erreur - Le champ ME contient " & diff & " | au lieu de 19"
                        detect = False
                     End If
                End If
                If Left(s, 3) = "TD|" Then
                    'Controle sur les limites
                    'Nbre |
                     num1 = Len(s)
                     strCount = Replace(s, "|", "")
                     num2 = Len(strCount)
                     diff = num1 - num2
                     If diff = 18 Then
                        detect = True
                     Else
                        MsgBox "Erreur - Le champ EV contient " & diff & " | au lieu de 18"
                        detect = False
                     End If
                End If
            Loop
            If detect = False Then
                MsgBox "Erreur - Une ou plusieurs lignes sont erronnées"
            Else
                MsgBox "Les Fichiers Qstat sont corrects !!"
            End If
        Close #ff 'fermeture
    Next i
 
    ' Affichage
    Dim cpt As Integer
    Dim Tableau() As String
    cpt = 1
    For cpt = 1 To UBound(fn)
        TbFn(cpt) = fn(cpt) 'fichier en cours
        If detect = True Then
            ff = FreeFile
            Worksheets("Feuil1").Select
            'Entete
            Cells(5, 1) = "Pas de Test"
            Cells(6, 1) = "Données Numérique"
            '---------------------
 
            'ouverture du fichier
            Open TbFn(cpt) For Input As ff
                While Not EOF(ff)
                    Line Input #ff, s
                    If Left(s, 3) = "ME|" Then
                        'on incrémente la ligne d'ecriture
                        cpt = cpt + 1
                        'on decompose
                        Tableau = Split(s, "|")
                        'on ecrit
                        Cells(5, cpt) = Tableau(4)
                        Cells(6, cpt) = Tableau(6)
                    End If
                Wend
            Close #ff
        End If
    Next cpt
End Sub

Bonjour,

attension au caractère séparation das champs [|].

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Function OpentTxt(Fichier As String) As Workbook
On Error Resume Next
        Workbooks.OpenText Fichier, Origin:=xlMSDOS, _
        StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _
        , Space:=False, Other:=True, OtherChar:="|", DecimalSeparator:=".", TrailingMinusNumbers:=True
Set OpentTxt = ActiveWorkbook
If InStr(Fichier, OpentTxt.Name) = 0 Then Set OpentTxt = Nothing
 On Error GoTo 0
 
End Function
 
 
Sub test()
Dim wb As Workbook
Set wb = OpentTxt("C:\Users\rdurupt\Desktop\A2C53347252_130710152147.txt")
If TypeName(wb) <> "Nothing" Then MsgBox wb.Name
End Sub

1 pièce(s) jointe(s)

Bonjour rdurupt,

Merci pour votre réponse, j'ai testé votre macro il extrait bien les données d'un fichier text. Mais moi ce que je voudrais c'est une fonction qui me permet d'extraire les données de plusieurs fichiers text et d'afficher leurs données sur une seule feuille excel (Concaténation) .

NB : on extrait une partie des données des fichiers

je suis arrivé a faire la fonction d'extaction pour plusieurs fichiers mais j'ai un probléme d'affichage des données sur excel car j'ai les données d'un seul fichier qui s'affichent. je crois que c'est un probleme de compteur

voici mon code d'affichage

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
 
 
 ' Affichage
    Dim cpt As Integer
    Dim Tableau() As String
    cpt = 1
    For cpt = 1 To UBound(fn)
        TbFn(cpt) = fn(cpt) 'fichier en cours
        If detect = True Then
            ff = FreeFile
            Worksheets("Feuil1").Select
            'Entete
            Cells(5, 1) = "Pas de Test"
            Cells(6, 1) = "Données Numérique"
            '---------------------
 
            'ouverture du fichier
            Open TbFn(cpt) For Input As ff
                While Not EOF(ff)
                    Line Input #ff, s
                    If Left(s, 3) = "ME|" Then
                        'on incrémente la ligne d'ecriture
                        cpt = cpt + 1
                        'on decompose
                        Tableau = Split(s, "|")
                        'on ecrit
                        Cells(5, cpt) = Tableau(4)
                        Cells(6, cpt) = Tableau(6)
                    End If
                Wend
            Close #ff
        End If
    Next cpt

voir exemple fichier faite manuellement en piece joint

07/01/2014, 14h50
Invité

ce que je ne comprends pas c'est que la fonction2 de ton premier poste fonctionne très bien!

hormis les décimaux qui son bizard!

ces pourquai j'ai mis ma fonction d'ouverture de fichier.
07/01/2014, 15h03
gibba88

Enfaite la fonction 2 permet seulement de faire une extraction brute de toutes les données des fichiers sélectionné ,alors que moi je voudrais une fonction qui me permettrais de faire une selection multiple de fichiers textes et d'extraire que les données correspondant à "ME". La fonction 1 me permet de réaliser cela mais elle le fait seulement avec un fichier texte selectionné

j'ais pas trop compris mai ça c'est un mixte des 2

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
Sub Fonction_concatenee()
Dim Fichiers As Variant
Dim i As Integer
Dim wb As Workbook
Dim donnees As Range
 
    Fichiers = Application.GetOpenFilename("Fichiers dat (*.txt), *.txt", , , , True)
 
    If IsArray(Fichiers) = True Then
 
        Application.ScreenUpdating = False
 
        For i = LBound(Fichiers) To UBound(Fichiers)
 
          QStat Trim("" & Fichiers(i)), ThisWorkbook.Sheets(1).[A65536].End(xlUp).Row + 1
 
        Next i
 
        Application.ScreenUpdating = True
 
    End If
End Sub
 
 
Sub QStat(Source As String, L As Long)
    Dim num1 As Integer
    Dim nim2 As Integer
    Dim diff As Integer
    Dim intFic As Integer
    Dim strLigne As String
    Dim detect As Boolean
    Dim strCount As String
 
 
    'affectation du repertoire
   'detect : Variable de controle de fichier
    detect = True
    intFic = FreeFile
    'ouverture du fichier
    Open Source For Input As intFic
    While Not EOF(intFic) And detect
        detect = False
        Line Input #intFic, strLigne
        If Left(strLigne, 3) = "EV|" Then
            'Controle sur le Event
                'Nbre |
                num1 = Len(strLigne)
                strCount = Replace(strLigne, "|", "")
                num2 = Len(strCount)
                diff = num1 - num2
                If diff = 35 Then
                    detect = True
                Else
                    MsgBox "Erreur - Le champ EV contient " & diff & " | au lieu de 35"
                    detect = False
                End If
        End If
        If Left(strLigne, 3) = "ME|" Then
            'Controle sur la mesure
                'Nbre |
                num1 = Len(strLigne)
                strCount = Replace(strLigne, "|", "")
                num2 = Len(strCount)
                diff = num1 - num2
                If diff = 19 Then
                    detect = True
                Else
                    MsgBox "Erreur - Le champ ME contient " & diff & " | au lieu de 19"
                    detect = False
                End If
        End If
        If Left(strLigne, 3) = "TD|" Then
            'Controle sur les limites
                'Nbre |
                num1 = Len(strLigne)
                strCount = Replace(strLigne, "|", "")
                num2 = Len(strCount)
                diff = num1 - num2
                If diff = 18 Then
                    detect = True
                Else
                    MsgBox "Erreur - Le champ EV contient " & diff & " | au lieu de 18"
                    detect = False
                End If
        End If
    Wend
    If detect = False Then
        MsgBox "Erreur - Une ou plusieurs lignes sont erronnées"
    Else
        MsgBox "Le Fichier Qstat est correct !!"
    End If
    Close intFic
 
    ' On passe à l'affichage
    Dim i As Integer
    Dim cpt As Integer
    Dim Tableau() As String
    i = 1
    cpt = 1
 
    If detect = True Then
        intFic = FreeFile
        'Entete
        ThisWorkbook.Sheets(1).Cells(L, 1) = "Pas de Test"
       ThisWorkbook.Sheets(1).Cells(L + 1, 1) = "Données Numérique"
 
        'ouverture du fichier
        Open Source For Input As intFic
        While Not EOF(intFic)
            Line Input #intFic, strLigne
            If Left(strLigne, 3) = "ME|" Then
                'on incrémente la ligne d'ecriture
                i = i + 1
                'on decompose
                Tableau = Split(strLigne, "|")
                'on ecrit
                 ThisWorkbook.Sheets(1).Cells(L, i) = Tableau(4)
                ThisWorkbook.Sheets(1).Cells(L + 1, i) = Tableau(6)
            End If
        Wend
    End If
End Sub

07/01/2014, 16h17
gibba88

C'est bien ce que je cherchais :ccool:. merci à vous