Importer plusieurs csv dans un seul classeur Excel

**matthieu44** · 30/01/2017, 09h21

Bonjour,

Je souhaite importer plusieurs fichiers csv dans un seul et unique classeur excel via une macro.

Via l'enregistreur de macro j'obtiens ceci :

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 Macro1()
'
' Macro1 Macro
'
 
'
    ChDir "Chemin du répertoire"
    Workbooks.OpenText Filename:= _
        "Nom du fichier.csv" _
        , Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
        xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=True, _
        Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
        Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _
        Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15 _
        , 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), _
        Array(22, 1)), TrailingMinusNumbers:=True
    Columns("A:V").Select
    Selection.AutoFilter
    Range("A2:V2").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Columns("A:V").Select
    Columns("A:V").EntireColumn.AutoFit
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets.OpenText Filename:= _
        "Nom du fichier.csv" _
        , Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
        xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=True, _
        Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
        Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _
        Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15 _
        , 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), _
        Array(22, 1)), TrailingMinusNumbers:=True
    Columns("A:V").Select
    Selection.AutoFilter
    Range("A2:V2").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Columns("A:V").Select
    Columns("A:V").EntireColumn.AutoFit
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
End Sub

=> Seulement les fichiers excel s'ouvrent dans des classeurs différents.

En parcourant le forum j'ai trouvé ce code qui semble répondre à mes attentes.

Seulement, j'ai deux problématiques :

- Comment l’intégrer dans le code précédant ?
- L'import s'effectue dans le même onglet. Comment générer un onglet par fichier ?

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
Sub csvImport()
Dim Wbcsv As Workbook
Dim Chemin As String, Fichier As String
Dim LastLig As Long, NewLig As Long
Dim c As Range
Dim Tablo
Const Sep As String = ";"
 
Application.ScreenUpdating = False                       'Inhibe la mise à jour affichage
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
Fichier = Dir(Chemin & "*.csv")                          'Le premier fichier csv trouvé
Do While Fichier <> ""                                   'on fait une boucle jusqu'à ce qu'on ne trouve plus de fichier csv
   Set Wbcsv = Workbooks.Open(Chemin & Fichier)          'On ouvre le fichier csv qu'on affecte à la variable Wbcsv
   With Wbcsv.Sheets(1)
      LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row     'LastLig est la dernière ligne remplie du fichier csv ouvert
   End With
   With ThisWorkbook.Worksheets("Feuil1")
      For Each c In Wbcsv.Sheets(1).Range("A2:A" & LastLig)   'Pour chaque cellule de A2:Axxx
         NewLig = .Cells(.Rows.Count, 1).End(xlUp).Row + 1   'la première cellule vide de la colonne 1 de Feuil1 de ce classeur
         Tablo = Split(c.Value, Sep)                        'On sépare les données par rapport au séparateur (ici le point virgule)
         .Range(.Cells(NewLig, 1), .Cells(NewLig, UBound(Tablo) + 1)).Value = Tablo   'on copie
      Next c
   End With
   Wbcsv.Close                                           'On ferme le fichier csv
   Fichier = Dir()                                       'on cherche le fichir csv suivant
Loop                                                     'on reboucle
End Sub

**Marc-L** · 30/01/2017, 10h05

Bonjour,

soit conserver la méthode actuelle (OpenText) et juste effectuer la copie d'une feuille d'un classeur vers un autre,
soit utiliser l'objet QueryTable (cf aide VBA), via la section Données, Importer à partir du Web …

_________________________________________________________________________________________________________

Je suis Paris, Istanbul, Berlin, Nice, Bruxelles, Charlie, …

Invité · 30/01/2017, 10h14

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
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
 #If VBA7 Then
Declare 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
 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é
 Do While Fichier <> ""
 Set rs = CreateObject("ADODB.RecordSet")
 rs.Open "select * from [" & Fichier & "]", Cn
txt = rs.GetString
txt = Replace("" & txt, ";", vbTab)
ClipBoard_SetData "" & txt
  With ThisWorkbook.Worksheets("Feuil1")
     .Cells(.Rows.Count, "A").End(xlUp).ofsset(1).PasteSpecial xlPasteAll
  End With
 Fichier = Dir
Wend
Cn.close :set Cn=nothing
End Sub
 
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** · 30/01/2017, 11h01

Envoyé par dysorthographie

J'ai une erreur à la compilation de ce code.

"Wend sans While"

Est-ce normal?

Matthieu

Invité · 30/01/2017, 11h10

Voila

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
 #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
 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é
 While Fichier <> ""
 Set rs = CreateObject("ADODB.RecordSet")
 rs.Open "select * from [" & Fichier & "]", Cn
txt = rs.GetString
txt = Replace("" & txt, ";", vbTab)
ClipBoard_SetData "" & txt
  With ThisWorkbook.Worksheets("Feuil1")
     .Cells(.Rows.Count, "A").End(xlUp).ofsset(1).PasteSpecial xlPasteAll
  End With
 Fichier = Dir
Wend
Cn.Close: Set Cn = Nothing
End Sub
 
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** · 30/01/2017, 11h24

J'ai désormais une erreur du type nom ambigu détecté sur GlobalLock.
D'après ce que je comprends il y'a une fonction qui porte deux fois le même nom...qu'il suffit de renommer mais comme je ne vois pas ou.

Invité · 13/02/2017, 10h04

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, 10h58

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

Invité · 03/02/2017, 09h35

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, 08h57

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.

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

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager