Lister fichier, extraire certaines données et les reincorporer dans un fichier final

**hyuntrax** · 07/08/2018, 15h07

Bonjour,

Je suis désolé je suis complètement novice... J'ai essayé de faire des recherches mais ma solution a l'air de se trouver dans plusieurs topics et je suis perdu, surtout qu'apparemment il existe plusieurs solutions à chaque fois...

La problématique :
Nous récupérons un fichier Excel de chaque fournisseur avec des commissions que l'on doit leur payer. Je dois récupérer sur chaque fichiers Excel la donnée qui se trouve dans la dernière ligne de la colonne S (le montant de la commission) et le nombre de ligne est aléatoire selon les fichiers (il varie en fonction du nombre d'acte).

Je dois donc lister les fichiers présents dans mon répertoire et ensuite je n'ai pas bien compris...certains parlent d'extraire les données sans ouvrir le fichier et d'autres en l'ouvrant.

Pour la cellule ceci peut être ma solution bien qu’apparemment maintenant le 65536 n’est plus d’actualité :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Range("S65536").End(xlUp).Row

Je dois également prendre la donnée de la cellule A qui sera de ce type : ENC005426202/08/2018 et en extraire ce code 0054262 qui est le numéro du fournisseur.
Il faudra ensuite que je compare ce code fournisseur avec un autre fichier pour le convertir car en local nous n'avons pas la même codification.

Ensuite je réintègre le montant de la commission et le code fournisseur convertit vers un nouveau tableau Excel pour pouvoir l'importer en comptabilité.

J'espère être assez claire...

J'aimerais réussir à mettre ceci en place car nous recevons en moyenne 400 fichiers tous les mois et à la main ça prend un temps monstrueux ! Et l’entreprise étant récente, chaque mois le nombre de fichiers augmente…

Merci par avance.

Cordialement.
Hyuntrax

**goldstar** · 07/08/2018, 16h03

Bonjour.

Ci-dessous une piste

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
 
Sub BoucleFichiers()
 
Dim Chemin As String, FichierCible As String, FichierSource As String
Dim derligneCible As Integer, derligneSource As Integer, numFrs As String, montantCommission As Double
 
'Définit le répertoire contenant les fichiers
Chemin = "C:\dossier\"
 
'Boucle sur tous les fichiers xls du répertoire.
FichierSource = Dir(Chemin & "*.xls")
 
'Utilisez la syntaxe suivante pour boucler sur tous les types de fichiers:
'Fichier = Dir(Chemin & "*.*")
 
    Do While Len(FichierSource) > 0
        ''ouverture du fichier.
        Workbooks.Open Chemin & FichierSource
 
        derligneSource = Workbooks(FichierSource).Worksheets("feuilleSource").Range("s" & Rows.Count).End(xlUp).Row
 
        montantCommission = Workbooks(FichierSource).Worksheets("feuilleSource").Cells(derligneSource, 19).Value '19 correspond à la colonne S
 
        numFrs = Workbooks(FichierSource).Worksheets("feuilleSource").Cells(derligneSource, 1).Value '1 correspond à la colonne A
        numFrs = Right(Left(numFrs, 10), 7)
 
        'DERNIERE LIGNE DU FICHIER CIBLE
         derligneCible = Workbooks("FichierCible").Worksheets("feuilleCible").Range("s" & Rows.Count).End(xlUp).Row + 1
         Workbooks("FichierCible").Worksheets("feuilleCible").Cells(derligneCible, 1) = numFrs
         Workbooks("FichierCible").Worksheets("feuilleCible").Cells(derligneCible, 2) = montantCommission
 
        Fichier = Dir()
    Loop
 
 
 
End Sub

Cordialement

**Theze** · 07/08/2018, 16h08

Bonjour,

Voici une piste ou les valeurs sont récupérées dans la dernière cellule de la colonne S de la feuille ayant l'index 1 du classeur en cours (ils sont ouverts et refermés les uns après les autres)
Il te faut adapter le chemin du dossier où se trouvent les classeurs (à la place de "C:\Mes documents\")
Pour ce qui est du code en colonne A, tu peux prendre exemple sur ce qui est fait sur la colonne S
Pour le test, les valeurs sont inscrites en colonne A à partir de A1 dans la feuille "Feuil1" (elle doit exister) du classeur où tu va coller ce code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub Test()
 
    Dim Classeur As Workbook
    Dim Cel As Range
    Dim Tbl() As String
    Dim Chemin As String
    Dim I As Integer
    Dim J As Integer
 
    Chemin = "C:\Mes documents\" '<-- adapter le nom du dossier, doit exister !
 
    'appel de la fonction...
    Tbl() = RecupFichiers(Chemin)
 
    'si le tableau a été initialisé...
    If Not Not Tbl Then
 
        Application.ScreenUpdating = False
 
        'ouvre les classeurs et récupère les valeurs de la dernière cellule en colonne S de la feuille ayant l'index 1
        'puis referme les classeurs
        'les valeurs sont inscrites en colonne A de la feuille "Feuil1" du classeur contenant la macro
        'les unes au dessous des autres
        For I = 1 To UBound(Tbl)
 
            Set Classeur = Workbooks.Open(Chemin & Tbl(I))
 
            With Classeur.Worksheets(1): Set Cel = .Cells(.Rows.Count, 19).End(xlUp): End With 'sur colonne S
            J = J + 1
            ThisWorkbook.Worksheets("Feuil1").Cells(J, 1).Value = Cel.Value
 
            Classeur.Close False
 
        Next I
 
        Application.ScreenUpdating = True
 
    End If
 
End Sub
 
Function RecupFichiers(Chemin As String) As String()
 
    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
 
    Fichier = Dir(Chemin & "*.xls*")
 
    Do While (Len(Fichier) > 0)
 
        I = I + 1
 
        ReDim Preserve TableauFichiers(1 To I)
 
        TableauFichiers(I) = Fichier
 
        Fichier = Dir()
 
    Loop
 
    RecupFichiers = TableauFichiers()
 
End Function

**hyuntrax** · 09/08/2018, 14h12

ok merci beaucoup pour votre aide, je vais voir si j'arrive à m'en servir.

Je vous tiens informé de l'avancé sans faute !

à bientôt !

**hyuntrax** · 09/08/2018, 17h23

Alors...

J'ai créé un fichier Excel avec prise en charge des macros, j'ai inséré un module et j'y ai collé vos codes. J'ai bien modifié les chemins des répertoires pour l'accès du dossier.
Que je lance l'un ou l'autre... Rien !
Cependant j'ai aussi au passage remarqué que ce sont des fichiers *.CSV.
Sont-ils traité différemment des fichiers Excel par nature ?

Merci par avance !!
Cordialement

Hyuntrax

**Theze** · 09/08/2018, 20h43

Bonjour,

Il te faut modifier la fonction comme ci-dessous :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 
Function RecupFichiers(Chemin As String) As String()
 
    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
 
    Fichier = Dir(Chemin & "*.csv")
 
    Do While (Len(Fichier) > 0)
 
        I = I + 1
 
        ReDim Preserve TableauFichiers(1 To I)
 
        TableauFichiers(I) = Fichier
 
        Fichier = Dir()
 
    Loop
 
    RecupFichiers = TableauFichiers()
 
End Function

ligne de code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
Fichier = Dir(Chemin & "*.xls*")

modifiée en :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
Fichier = Dir(Chemin & "*.csv")

**hyuntrax** · 10/08/2018, 10h26

Oui j'avais essayé cette solution au cas ou mais non ça ne change rien.
Peut être que je n'utilise pas bien le code... c'est la 1ere fois que je fais ça...

J'ai fait un test avec 3 fichiers que j'ai mis dans "C:\test" chaque fichier s'appelle fichier1.csv fichier2 etc et j'ai aussi mis mon fichier contenant le code que j'ai nommé vba.xlsm.

Je lance vba puis je fais Alt+F11.
Là je clique sur démarrer et je sélectionne un des 2 modules.
Ça a l'air de réagir car la souris tourne 1/4 de seconde.
Mais quand je reviens sur mon fichier vba le tableau est toujours vide.

Est-ce que ce n'est pas juste un problème d'utilisation ?!...

Merci à vous

Hyuntrax

**Theze** · 10/08/2018, 16h11

Désolé,

Comme c'est un fichier .csv (donc, un fichier texte) la récup de la valeur est légèrement différente !
Voici le code pour avoir la valeur de la dernière cellule en colonne S de chaque fichier .csv du dossier. Il est nécessaire de connaître le séparateur des valeur ici, je suis parti du point-virgule si différent, adapter :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub Test()
 
    Dim Tbl() As String
    Dim T
    Dim Chemin As String
    Dim I As Integer
    Dim Ligne As String
    Dim Lig As Long
 
    Chemin = "C:\test\" '<-- adapter le nom du dossier, doit exister !
 
    'appel de la fonction...
    Tbl() = RecupFichiers(Chemin)
 
    'si le tableau a été initialisé...
    If Not Not Tbl Then
 
        Application.ScreenUpdating = False
 
        For I = 1 To UBound(Tbl)
 
            'ouvre le fichier en lecture et récupère chaque
            'ligne dans un tableau dont le séparateur est le point-virgule, adapter si différent !
            Open Chemin & Tbl(I) For Input As #1
 
                Do While Not EOF(1)
 
                    Line Input #1, Ligne
 
                    T = Split(Ligne, ";") '<--- adapter le séparateur si ce n'est pas le ;
 
                Loop
            'recherche en colonne A du .xlsm la dernière cellule non vide et décale de une vers le bas
            With ThisWorkbook.Worksheets("Feuil1"): Lig = .Cells(.Rows.Count, 1).End(xlUp).Row + 1: End With 'sur colonne S
            'et pour avoir la valeur de la dernière cellule en colonne S, il suffit de de récupérer la valeur une fois la boucle finie
            ThisWorkbook.Worksheets("Feuil1").Cells(Lig, 1).Value = T(18)
 
            Close #1
 
        Next I
 
        Application.ScreenUpdating = True
 
    End If
 
End Sub

**hyuntrax** · 13/08/2018, 10h51

Envoyé par Theze

Désolé,

Comme c'est un fichier .csv (donc, un fichier texte) la récup de la valeur est légèrement différente !
Voici le code pour avoir la valeur de la dernière cellule en colonne S de chaque fichier .csv du dossier. Il est nécessaire de connaître le séparateur des valeur ici, je suis parti du point-virgule si différent, adapter :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub Test()
 
    Dim Tbl() As String
    Dim T
    Dim Chemin As String
    Dim I As Integer
    Dim Ligne As String
    Dim Lig As Long
 
    Chemin = "C:\test\" '<-- adapter le nom du dossier, doit exister !
 
    'appel de la fonction...
    Tbl() = RecupFichiers(Chemin)
 
    'si le tableau a été initialisé...
    If Not Not Tbl Then
 
        Application.ScreenUpdating = False
 
        For I = 1 To UBound(Tbl)
 
            'ouvre le fichier en lecture et récupère chaque
            'ligne dans un tableau dont le séparateur est le point-virgule, adapter si différent !
            Open Chemin & Tbl(I) For Input As #1
 
                Do While Not EOF(1)
 
                    Line Input #1, Ligne
 
                    T = Split(Ligne, ";") '<--- adapter le séparateur si ce n'est pas le ;
 
                Loop
            'recherche en colonne A du .xlsm la dernière cellule non vide et décale de une vers le bas
            With ThisWorkbook.Worksheets("Feuil1"): Lig = .Cells(.Rows.Count, 1).End(xlUp).Row + 1: End With 'sur colonne S
            'et pour avoir la valeur de la dernière cellule en colonne S, il suffit de de récupérer la valeur une fois la boucle finie
            ThisWorkbook.Worksheets("Feuil1").Cells(Lig, 1).Value = T(18)
 
            Close #1
 
        Next I
 
        Application.ScreenUpdating = True
 
    End If
 
End Sub

Merci pour la réponse, je l'ai testé et en y ajoutant le code de la fonction.

j'ai donc maintenant

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub Test()
 
    Dim Tbl() As String
    Dim T
    Dim Chemin As String
    Dim I As Integer
    Dim Ligne As String
    Dim Lig As Long
 
    Chemin = "C:\test\" '<-- adapter le nom du dossier, doit exister !
 
    'appel de la fonction...
    Tbl() = RecupFichiers(Chemin)
 
    'si le tableau a été initialisé...
    If Not Not Tbl Then
 
        Application.ScreenUpdating = False
 
        For I = 1 To UBound(Tbl)
 
            'ouvre le fichier en lecture et récupère chaque
            'ligne dans un tableau dont le séparateur est le point-virgule, adapter si différent !
            Open Chemin & Tbl(I) For Input As #1
 
                Do While Not EOF(1)
 
                    Line Input #1, Ligne
 
                    T = Split(Ligne, ";") '<--- adapter le séparateur si ce n'est pas le ;
 
                Loop
            'recherche en colonne A du .xlsm la dernière cellule non vide et décale de une vers le bas
            With ThisWorkbook.Worksheets("Feuil1"): Lig = .Cells(.Rows.Count, 1).End(xlUp).Row + 1: End With 'sur colonne S
            'et pour avoir la valeur de la dernière cellule en colonne S, il suffit de de récupérer la valeur une fois la boucle finie
            ThisWorkbook.Worksheets("Feuil1").Cells(Lig, 1).Value = T(18)
 
            Close #1
 
        Next I
 
        Application.ScreenUpdating = True
 
    End If
 
End Sub
 
Function RecupFichiers(Chemin As String) As String()
 
    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
 
    Fichier = Dir(Chemin & "*.csv")
 
    Do While (Len(Fichier) > 0)
 
        I = I + 1
 
        ReDim Preserve TableauFichiers(1 To I)
 
        TableauFichiers(I) = Fichier
 
        Fichier = Dir()
 
    Loop
 
    RecupFichiers = TableauFichiers()
 
End Function

Donc il récupère bien des données...mais il me récupère le mot "commission" qui est 3 lignes au dessus de la dernière ligne et non le montant de la dernière ligne de la colonne S.
Je suis désolé de faire l'assisté mais là le code ne me parle pas du tout...

Merci encore de m'aider c'est très apprécié !

à bientôt !

**Theze** · 13/08/2018, 20h34

Bonjour,

Poste un exemple de ton .csv pour vois !

**hyuntrax** · 14/08/2018, 10h29

Bonjour,

Voici les fichiers que j'utilise ainsi que celui qui contient le code.

J'espère ne pas vous prendre trop de temps avec ce problème.

Merci !

**Theze** · 14/08/2018, 11h10

Bonjour,

je viens de faire le test à l'instant, et les valeurs retournées sont :
140,94
11,56
68026,54

donc, je ne comprend pas pourquoi tu as "COMMISSION" qui est retourné ?

**hyuntrax** · 14/08/2018, 11h15

Envoyé par Theze

Bonjour,

je viens de faire le test à l'instant, et les valeurs retournées sont :
140,94
11,56
68026,54

donc, je ne comprend pas pourquoi tu as "COMMISSION" qui est retourné ?

Tu as directement lancé le code sans rien modifier ?

Si c'est le cas c'est que je dois avoir une option dans excel à aller modifier... c'est office 365, ça change quelque chose ? Car c'est bien excel 2016 dans le 365 non ?

**hyuntrax** · 14/08/2018, 11h31

Je viens d'essayer sur un autre poste du bureau et j'ai aussi la valeur "commission" qui remonte... est-ce un réglage par défaut qu'il faudra modifier ?

**Theze** · 14/08/2018, 13h52

Re,

Tu as directement lancé le code sans rien modifier ?

Oui, sans absolument rien modifier !

Si c'est le cas c'est que je dois avoir une option dans excel à aller modifier... c'est office 365, ça change quelque chose ? Car c'est bien excel 2016 dans le 365 non ?

J'ai Excel 2007 donc il se peut que ça vienne de là !
Je regarde avec ADO et te re-poste un code que tu devras tester

**Theze** · 14/08/2018, 14h13

Re,

Testes le code ci-dessous (à mettre dans un nouveau module standard, j'ai aussi mis la fonction de récup des fichiers) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub TestADO()
 
    Dim Tbl() As String
    Dim T
    Dim Chemin As String
    Dim I As Integer
 
    Chemin = "C:\Dossier\" '<adapte le chemin du dossier !
 
    Tbl() = RecupFichiers(Chemin)
 
    If Not Not Tbl Then
 
        For I = 1 To UBound(Tbl)
 
            T = Split(Recup(Chemin, Tbl(I)), ";") '<--- adapter le séparateur si ce n'est pas le ;
 
            With ThisWorkbook.Worksheets("Feuil1"): .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1).Value = T(18): End With
 
        Next I
 
    End If
 
 
End Sub
 
Private Sub ConnectCLasseur(ConnectCL As Object, _
                            Dossier As String, _
                            Optional Rs)
 
    Set ConnectCL = CreateObject("ADODB.Connection")
 
    If Not IsMissing(Rs) Then Set Rs = CreateObject("ADODB.Recordset")
 
    ConnectCL.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                   "Data Source=" & Dossier & ";" & _
                   "Extended Properties=""text;HDR=YES;FMT=Delimited;"""
 
End Sub
 
Function Recup(Dossier As String, Fichier As String)
 
    Dim Connect As Object
    Dim Rs As Object
    Dim Valeur As String
 
    'ouvre une première connexion pour la recherche
    ConnectCLasseur Connect, Dossier, Rs
 
    'ouvre pour récupérer les valeurs
    With Rs
 
        .Open "SELECT * FROM [" & Fichier & "]", Connect, 3, 1, 1
        .MoveLast 'va à la dernière ligne
        Valeur = .Fields(0).Value
 
    End With
 
    'ferme la connexion
    Connect.Close
 
    Set Connect = Nothing
    Set Rs = Nothing
 
    Recup = Valeur
 
End Function
 
Function RecupFichiers(Chemin As String) As String()
 
    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
 
    Fichier = Dir(Chemin & "*.csv")
 
    Do While (Len(Fichier) > 0)
 
        I = I + 1
 
        ReDim Preserve TableauFichiers(1 To I)
 
        TableauFichiers(I) = Fichier
 
        Fichier = Dir()
 
    Loop
 
    RecupFichiers = TableauFichiers()
 
End Function

Chez moi, la récupération des valeurs de la dernière ligne se fait bien mais le problème est que la partie décimale n'est pas récupérée et c'est probablement dû à la virgule !

**hyuntrax** · 14/08/2018, 14h25

Envoyé par Theze

Re,

Testes le code ci-dessous (à mettre dans un nouveau module standard, j'ai aussi mis la fonction de récup des fichiers) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub TestADO()
 
    Dim Tbl() As String
    Dim T
    Dim Chemin As String
    Dim I As Integer
 
    Chemin = "C:\Dossier\" '<adapte le chemin du dossier !
 
    Tbl() = RecupFichiers(Chemin)
 
    If Not Not Tbl Then
 
        For I = 1 To UBound(Tbl)
 
            T = Split(Recup(Chemin, Tbl(I)), ";") '<--- adapter le séparateur si ce n'est pas le ;
 
            With ThisWorkbook.Worksheets("Feuil1"): .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1).Value = T(18): End With
 
        Next I
 
    End If
 
 
End Sub
 
Private Sub ConnectCLasseur(ConnectCL As Object, _
                            Dossier As String, _
                            Optional Rs)
 
    Set ConnectCL = CreateObject("ADODB.Connection")
 
    If Not IsMissing(Rs) Then Set Rs = CreateObject("ADODB.Recordset")
 
    ConnectCL.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                   "Data Source=" & Dossier & ";" & _
                   "Extended Properties=""text;HDR=YES;FMT=Delimited;"""
 
End Sub
 
Function Recup(Dossier As String, Fichier As String)
 
    Dim Connect As Object
    Dim Rs As Object
    Dim Valeur As String
 
    'ouvre une première connexion pour la recherche
    ConnectCLasseur Connect, Dossier, Rs
 
    'ouvre pour récupérer les valeurs
    With Rs
 
        .Open "SELECT * FROM [" & Fichier & "]", Connect, 3, 1, 1
        .MoveLast 'va à la dernière ligne
        Valeur = .Fields(0).Value
 
    End With
 
    'ferme la connexion
    Connect.Close
 
    Set Connect = Nothing
    Set Rs = Nothing
 
    Recup = Valeur
 
End Function
 
Function RecupFichiers(Chemin As String) As String()
 
    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
 
    Fichier = Dir(Chemin & "*.csv")
 
    Do While (Len(Fichier) > 0)
 
        I = I + 1
 
        ReDim Preserve TableauFichiers(1 To I)
 
        TableauFichiers(I) = Fichier
 
        Fichier = Dir()
 
    Loop
 
    RecupFichiers = TableauFichiers()
 
End Function

Chez moi, la récupération des valeurs de la dernière ligne se fait bien mais le problème est que la partie décimale n'est pas récupérée et c'est probablement dû à la virgule !

Merci ça fonctionne ! Effectivement il me récupère seulement le nombre entier et pas la partie décimale.

En tout cas c'est cool ça avance !
Ce problème de décimale je peux essayer de trouver une solution seul tu en as déjà fait beaucoup !

C'est super gentil de ta part d'avoir fait tout ça. Je vais dire à mon boss de te virer une prime ! mdr

Après si d'autres personnes ont une idée pour récupérer la partie décimale n'hésitez surtout pas !

**Theze** · 14/08/2018, 14h34

Heureux de t'aider, je vais te poster mon RIB

On voit bien que c'est la virgule qui pose problème car avec le première code si je fais un Debug.Print sur la dernière ligne j'obtiens :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
ENC005426203/07/2018;TO;;;;;;;;;;;;;;;;;140,94;;;-140,94;;;;

avec le dernier code" que je t'ai donné, j'obtiens :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
ENC005426203/07/2018;TO;;;;;;;;;;;;;;;;;140

on peut voir que plus rien n'est récupéré après la virgule !
Je regarde si je trouve une solution

**Theze** · 14/08/2018, 15h21

Voici une autre piste avec une requête (après, je vais être à court de cartouches) Elle appelle aussi la fonction "RecupFichiers()" donc, ne pas oublier de lui mettre avec :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub TestRequete()
 
    Dim Fe As Worksheet
    Dim Tbl() As String
    Dim Chemin As String
    Dim I As Integer
 
    'le chemin du fichier cible, à adapter
    Chemin = "C:\Dossier\"
 
    Tbl() = RecupFichiers(Chemin)
 
    If Not Not Tbl Then
 
        Application.ScreenUpdating = False 'gèle l'affichage pour ne pas voir l'ajout de la feuille
 
        'ajoute une feuille qui va servir de transfert et la cache
        Set Fe = Worksheets.Add
        Fe.Visible = xlSheetHidden
 
        'exécute les requêtes sur le fichiers
        For I = 1 To UBound(Tbl)
 
            With Fe.QueryTables.Add("TEXT;" & Chemin & Tbl(I), Fe.Range("A1"))
 
                .TextFileSemicolonDelimiter = True 'le délimiteur est le point-virgule (;)
                .Refresh 'met à jour
                .Delete 'supprime la requête
 
            End With
 
            'récupère la valeur de la dernière cellule de la colonne S...
            With ThisWorkbook.Worksheets("Feuil1"): .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1).Value = Fe.Cells(Rows.Count, 19).End(xlUp).Value: End With
 
            'puis vide la feuille pour la récup suivante
            Fe.Cells.Clear
 
        Next I
 
        With Application
 
            .ScreenUpdating = True
            .DisplayAlerts = False
            Fe.Delete 'suppression de la feuille de transfert puisque plus utile
            .DisplayAlerts = True
 
        End With
 
    End If
 
End Sub

**hyuntrax** · 17/08/2018, 09h40

Merci pour ton aide !

Une autre personne a réussi à me faire fonctionner le code sous excel 2016 donc je te le transmet, on ne sait jamais ça pourrait t'aider un jour !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub TestADO()
 
    Dim Tbl() As String
    Dim T
    Dim Chemin As String
    Dim I As Integer
 
    Chemin = "C:\TEST\" '<adapte le chemin du dossier !
 
    Tbl() = RecupFichiers(Chemin)
 
    If Not Not Tbl Then
 
        For I = 1 To UBound(Tbl)
 
            T = Split(Recup(Chemin, Tbl(I)), "-") '<--- adapter le séparateur si ce n'est pas le ;
 
            With ThisWorkbook.Worksheets("Feuil1")
                .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1).Value = Left(T(0), Len(T(0)) - 10)
                .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row + 1, 2).Value = T(1) * 1
            End With
 
        Next I
 
    End If
 
End Sub
 
Private Sub ConnectCLasseur(ConnectCL As Object, _
                            Dossier As String, _
                            Optional Rs)
 
    Set ConnectCL = CreateObject("ADODB.Connection")
 
    If Not IsMissing(Rs) Then Set Rs = CreateObject("ADODB.Recordset")
 
    ConnectCL.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                   "Data Source=" & Dossier & ";" & _
                   "Extended Properties=""text;HDR=YES;FMT=Delimited();"""
 
End Sub
 
Function Recup(Dossier As String, Fichier As String)
 
    Dim Connect As Object
    Dim Rs As Object
    Dim Valeur1 As String
    Dim Valeur2 As Double
 
    'ouvre une première connexion pour la recherche
    ConnectCLasseur Connect, Dossier, Rs
 
    'ouvre pour récupérer les valeurs
    With Rs
        Call fncWriteSchmIni(Dossier, Fichier)
        .Open "SELECT * FROM [" & Fichier & "]", Connect, 3, 1, 1
        .MoveLast 'va à la dernière ligne
        Valeur1 = .Fields(0).Value
        Valeur2 = Abs(.Fields(21).Value)
 
    End With
 
    'ferme la connexion
    Connect.Close
 
    Set Connect = Nothing
    Set Rs = Nothing
 
    Recup = Valeur1 & "-" & Valeur2
 
End Function
 
Function RecupFichiers(Chemin As String) As String()
 
    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
 
    Fichier = Dir(Chemin & "*.csv")
 
    Do While (Len(Fichier) > 0)
 
        I = I + 1
 
        ReDim Preserve TableauFichiers(1 To I)
 
        TableauFichiers(I) = Fichier
 
        Fichier = Dir()
 
    Loop
 
    RecupFichiers = TableauFichiers()
 
End Function
 
Private Sub fncWriteSchmIni(Dossier, Fichier)
' Requires Microsoft Scripting Environment
 
Dim varFSO As FileSystemObject
Dim varStrm As TextStream
Dim varFL As File
 
Set varFSO = New FileSystemObject
'Verif Existence fichier
If varFSO.FileExists(Dossier & "\schema.ini") Then varFSO.DeleteFile (Dossier & "\schema.ini")
'create the file in the source directory
Set varStrm = varFSO.CreateTextFile(Dossier & "\schema.ini", True)
'write the specifications needed
varStrm.Write "[" & Fichier & "]" & Chr(13) & Chr(10) & _
"ColNameHeader = False" & Chr(13) & Chr(10) & _
"Format = Delimited(;)"
 
Set varFL = varFSO.GetFile(Dossier & "\schema.ini")
 
End Sub

Super aimable d'avoir investit ton temps !

Peut-être à bientôt pour de nouvelles galères !

Cordialement
Hyuntrax

Lister fichier, extraire certaines données et les reincorporer dans un fichier final

Macros et VBA Excel

Discussions similaires

Partager

Partager