Importer plusieurs csv dans un seul classeur Excel

**matthieu44** · 03/02/2017, 09h53

soit tu ajout un nouveau classeur!

Code :

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

1
2
set wb= Workbooks.add
With wb.Worksheets.add .Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteAll

J'utilise cette option que j'ai insérer dans mon code comme suit :

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
Sub test()
Dim Cn As Object, txt As String
Chemin = ThisWorkbook.Path & "\"                                   'Chemin du dossier où chercher les fichiers csv (Ici ce classeur se trouve dans ce même dossier, sinon on peut êcrire ici le chemin du dossier
Set Cn = CreateObject("Adodb.Connection")
 Cn.Open "Provider =Microsoft.Jet.OLEDB.4.0;Data Source=" & Chemin & ";Extended Properties=""Text;HDR=YES;FMT=Delimited(;);"";"
  Fichier = Dir(Chemin & "*.csv")                       'Le premier fichier csv trouvé
Set wb = Workbooks.Add
 While Fichier <> ""
 Set rs = CreateObject("ADODB.RecordSet")
 rs.Open "select * from [" & Fichier & "]", Cn
txt = rs.GetString
txt = Replace("" & txt, ";", vbTab)
ClipBoard_SetData "" & txt
With wb.Worksheets.Add
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteAll
End With
 Fichier = Dir
Wend
Cn.Close: Set Cn = Nothing
End Sub

Cela fonctionne mais les onglets ne prennent pas le nom du fichier importé. Par ailleurs, j'ai toujours les trois onglets de bases feuil1, 2 et 3 qui s'ouvrent en plus.

Peut-on rectifier le problème?

Par ailleurs, mon fichier csv contient à certains endroits des "," qu'il interprête comme des ";" à l'import ce qui créé des décalages dans les colonnes. Alors que lors d'un import manuel > données > convertir je n'ai pas le soucis.

Invité · 03/02/2017, 10h35

Bonjour,

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
Private Sub test()
Dim Cn As Object, txt As String, Fichier As String,Rs As Object
Set Cn = CreateObject("Adodb.Connection")
Cn.Open ("Provider =Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.Path & ";Extended Properties=""Text;HDR=YES;FMT=Delimited(;);"";")
With Workbooks.Add
    Fichier = Dir(ThisWorkbook.Path & "\" & "*.csv")                          'Le premier fichier csv trouvé
    While Fichier <> ""
        Set rs = Cn.Execute("select * from [" & Fichier & "]")
        txt = rs.GetString
        txt = Replace("" & txt, ";", vbTab)
                ClipBoard_SetData "" & txt
        With .Worksheets.Add
            .Name = Left(Replace(Fichier, ".", "_"), 31)
            .Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteAll
        End With
        Fichier = Dir
    Wend
   For i = .Sheets.Count To 1 Step -1
    If .Sheets(i).UsedRange.Count = 1 Then
       If .Sheets(i).UsedRange = "" Then Application.DisplayAlerts = False: .Sheets(i).Delete: Application.DisplayAlerts = True
    End If
Next
End With
Cn.Close: Set Cn = Nothing
End Sub

**matthieu44** · 13/02/2017, 09h57

Merci pour ce retour rapide! Ce qui n'est pas mon cas !!
D'après ce que je comprend le code ci-dessus intègre le fait que dans le fichier il y'a des virgules et qu'il doit les supprimer.
Mais après avoir testé cela ne semble toujours pas fonctionner.

Invité · 13/02/2017, 11h04

Bonjour,

D'après ce que je comprend le code ci-dessus intègre le fait que dans le fichier il y'a des virgules et qu'il doit les supprimer.
Mais après avoir testé cela ne semble toujours pas fonctionner.

c'est très bien si tu as compris ça, car mon code ne fait absolument pas ça!

**matthieu44** · 13/02/2017, 11h58

Ah...dsl en même temps je n'ai que peu de connaissance en vba !

Invité · 13/02/2017, 12h18

Dans mon code je recherche les fichier csv; je fais une requête adodb pour lire le contenu du fichier; je converti le [;] en tabulation pour le séparateur de celles;j'envoie le txt dans le presse papier ; je colle dans Excel; Pui je supprime le onglets vides.

**matthieu44** · 13/02/2017, 12h26

Ok je vois mieux.

Avec l'enregistreur de macro, j'obtiens ce morceau de code :

Code :

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

1
2
3
' Supression des virgules
Cells.Replace What:=",", Replacement:="", LookAt:=xlPart, SearchOrder:= _
xlByColumns, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

J'ai essayé de l'insérer à différents endroits mais ce n'est pas concluant.

Invité · 13/02/2017, 12h43

Code :

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

txt = Replace(Replace("" & txt, ";", vbTab),",","")

**matthieu44** · 13/02/2017, 12h55

Envoyé par dysorthographie

Code :

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

txt = Replace(Replace("" & txt, ";", vbTab),",","")

En lieu et place de :

Code :

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

        txt = Replace("" & txt, ";", vbTab)

dans

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
Private Sub test()
Dim Cn As Object, txt As String, Fichier As String,Rs As Object
Set Cn = CreateObject("Adodb.Connection")
Cn.Open ("Provider =Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.Path & ";Extended Properties=""Text;HDR=YES;FMT=Delimited(;);"";")
With Workbooks.Add
    Fichier = Dir(ThisWorkbook.Path & "\" & "*.csv")                          'Le premier fichier csv trouvé
    While Fichier <> ""
        Set rs = Cn.Execute("select * from [" & Fichier & "]")
        txt = rs.GetString
        txt = Replace("" & txt, ";", vbTab)
                ClipBoard_SetData "" & txt
        With .Worksheets.Add
            .Name = Left(Replace(Fichier, ".", "_"), 31)
            .Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteAll
        End With
        Fichier = Dir
    Wend
   For i = .Sheets.Count To 1 Step -1
    If .Sheets(i).UsedRange.Count = 1 Then
       If .Sheets(i).UsedRange = "" Then Application.DisplayAlerts = False: .Sheets(i).Delete: Application.DisplayAlerts = True
    End If
Next
End With
Cn.Close: Set Cn = Nothing
End Sub

Invité · 13/02/2017, 13h09

Oui

**matthieu44** · 13/02/2017, 13h26

Ne fonctionne pas !

Invité · 13/02/2017, 13h31

Les virgules ne sont pas supprimées?

**matthieu44** · 13/02/2017, 13h36

En fait, si elles le sont surement mais dans mon fichier import.csv j'ai des passages du styles :

Code :

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

NON-PLANIFIE;0;Job a stop, non planifie;

Et une fois l'import effectué j'ai "job a stop" dans une colonne et "non planifié" dans une autre alors qu'en fait ils doivent être dans la même colonne.

Invité · 13/02/2017, 13h44

En fait le [;]_est le caractère de séparation de colonne dans un csv! Si le texte a l'intérieur d'une colonne en contient difficile de faire le distingo!

Si le csv utilise de tabulations comme séparateurs plus de problème sauf si ob trouve des tabulation dans un colonne .

Ça me paraît un {"salubres"}!

**matthieu44** · 13/02/2017, 14h03

Envoyé par dysorthographie

En fait le [;]_est le caractère de séparation de colonne dans un csv! Si le texte a l'intérieur d'une colonne en contient difficile de faire le distingo!

Il s'agit de , et non pas de ; je ne vois pas ou il est compliqué de faire le distingo ?
Le fait de supprimer les virgules au moment de l'import comme on tenter de le faire aurai du résoudre le problème.

bref un grand merci à toi en tout cas...! Et si jamais quelqu'un à une solution je suis toujours preneur.

Invité · 13/02/2017, 14h11

Je comprends vite mais il me faut du temps et la je viens de comprendre !

Je regarde.

Ma méthode avec sql n'est même pas la mayeur , je corrige ça!

Au moins la mettre a l'épreuve m'aura appris cela, désolé!

EDIT:

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
Private Sub test()
Dim txt As String, Fichier As String, Rs As Object
With Workbooks.Add
    Fichier = Dir(ThisWorkbook.Path & "\" & "*.csv")                          'Le premier fichier csv trouvé
    While Fichier <> ""
        txt = OuvrirFichier(Fichier)
        txt = Replace("" & txt, ";", vbTab)
                ClipBoard_SetData "" & txt
        With .Worksheets.Add
            .Name = Left(Replace(Fichier, ".", "_"), 31)
            .Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteAll
        End With
        Fichier = Dir
    Wend
   For I = .Sheets.Count To 1 Step -1
    If .Sheets(I).UsedRange.Count = 1 Then
       If .Sheets(I).UsedRange = "" Then Application.DisplayAlerts = False: .Sheets(I).Delete: Application.DisplayAlerts = True
    End If
Next
End With
End Sub
Public Function OuvrirFichier(Fichier)
Set oFs = CreateObject("Scripting.FileSystemObject")
Set oFile = oFs.OpenTextFile(Fichier)
OuvrirFichier = oFile.ReadAll
oFile.Close
End Function

**matthieu44** · 14/02/2017, 09h12

J'ai un erreur 53 (fichier introuvable) sur cette ligne.

Code :

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

Set oFile = oFs.OpenTextFile(Fichier)

Invité · 14/02/2017, 10h54

Bonjour,
On va arriver!

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
 #If VBA7 ThenDeclare PtrSafe  Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare  PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare PtrSafe  Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare PtrSafe  Function CloseClipboard Lib "User32" () As Long
Declare PtrSafe  Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare PtrSafe  Function EmptyClipboard Lib "User32" () As Long
Declare  PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare  PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
#Else
 Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
#End If
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096
Private Sub test()
Dim txt As String, Rep As String, Fichier As String, Rs As Object
Rep = ThisWorkbook.Path & "\"
With Workbooks.Add
    Fichier = Dir(Rep & "*.csv")                          'Le premier fichier csv trouvé
    While Fichier <> ""
        txt = OuvrirFichier(Rep & Fichier)
        txt = Replace("" & txt, ";", vbTab)
                ClipBoard_SetData "" & txt
        With .Worksheets.Add
            .Name = Left(Replace(Fichier, ".", "_"), 31)
            .Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteAll
        End With
        Fichier = Dir
    Wend
   For I = .Sheets.Count To 1 Step -1
    If .Sheets(I).UsedRange.Count = 1 Then
       If .Sheets(I).UsedRange = "" Then Application.DisplayAlerts = False: .Sheets(I).Delete: Application.DisplayAlerts = True
    End If
Next
End With
End Sub
Public Function OuvrirFichier(Fichier)
Set oFs = CreateObject("Scripting.FileSystemObject")
Set oFile = oFs.OpenTextFile(Fichier)
OuvrirFichier = oFile.ReadAll
oFile.Close
End Function
Function ClipBoard_SetData(MyString As String)
   Dim hGlobalMemory As Long, lpGlobalMemory As Long
   Dim hClipMemory As Long, X As Long
 
   ' Allocate moveable global memory.
   '-------------------------------------------
   hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
 
   ' Lock the block to get a far pointer
   ' to this memory.
   lpGlobalMemory = GlobalLock(hGlobalMemory)
 
   ' Copy the string to this global memory.
   lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
 
   ' Unlock the memory.
   If GlobalUnlock(hGlobalMemory) <> 0 Then
      MsgBox "Could not unlock memory location. Copy aborted."
      GoTo OutOfHere2
   End If
 
   ' Open the Clipboard to copy data to.
   If OpenClipboard(0&) = 0 Then
      MsgBox "Could not open the Clipboard. Copy aborted."
      Exit Function
   End If
 
   ' Clear the Clipboard.
   X = EmptyClipboard()
 
   ' Copy the data to the Clipboard.
   hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
 
OutOfHere2:
 
   If CloseClipboard() = 0 Then
      MsgBox "Could not close Clipboard."
   End If
 
   End Function

**matthieu44** · 14/02/2017, 12h04

Top !
Tout fonctionne nickel ! Merci pour ton aide

Importer plusieurs csv dans un seul classeur Excel [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager