XL 2019 Importer fichier csv sans consatener les colonnes

C

carlos

XLDnaute Impliqué
Supporter XLD
Bonjour,
Cette macro ci dessous, me permet d'importer le contenu de plusieurs fichiers ".csv".
Ces fichiers ont plusieurs colonne et lignes avec des valeurs bien séparées.
Ce quie je ne comprends pas c'est qu'il me concatène toutes les colonnes entre elles.
Est il possible de faire une copie des cellule sans cioncatenage?
Merci et bonne soirée

VB: 
Sub Bouton2_Cliquer()

Dim wbDest As Workbook, wbSource As Workbook
Dim wsDest As Worksheet, wsSource As Worksheet
Dim myFile As String, myPath As String

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set wbDest = ThisWorkbook
    Set wsDest = wbDest.Worksheets(1)
    myPath = "D:\Dossier Dest\"
    myFile = Dir(myPath & "*.csv")

    Do While myFile <> ""
        Set wbSource = Workbooks.Open(myPath & myFile)
        Set wsSource = wbSource.Worksheets(Split(myFile, ".")(0))
            wsSource.Unprotect
            wsSource.Cells(1).CurrentRegion.Copy

        wsSource.Range(Cells(1, 1), Cells(24, 24)).Copy
        With wbDest
            .Worksheets.Add After:=Worksheets(Worksheets.Count)
           If IsError(Evaluate("=" & wsSource.Name & "!A1")) Then
                ' si la feuille n'existe pas
               .ActiveSheet.Name = wsSource.Name
            Else
                .ActiveSheet.Name = wsSource.Name
            End If
            .Activate
            .ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues
        End With
        wbSource.Close
        myFile = Dir

    Loop

    Set wsDest = Nothing: Set wsSource = Nothing
    Set wbDest = Nothing: Set wbSource = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
 
Dernière modification par un modérateur:
Solution
job75
Voici une 3ème méthode, très rapide aussi, par requête QueryTables :
VB: 
Private Sub CommandButton3_Click()
Dim t, wbDest As Workbook, myPath$, myFile$, cn As Object, mySheetName$
t = Timer
Set wbDest = ThisWorkbook
'myPath = "D:\Lycée Stéphane Hessel\OneDrive - Lycée Stéphane Hessel\Karl EPS\Protocoles BGT BCP CAP 23\Import Fichiers Santorin\"
myPath = wbDest.Path & "\"
myFile = Dir(myPath & "*.csv")
Application.ScreenUpdating = False
For Each cn In wbDest.Connections: cn.Delete: Next 'supprime les connexions existantes
Do While myFile <> ""
    mySheetName = Left(myFile, Len(myFile) - 4)
    With wbDest
        .Activate
        On Error Resume Next
        .Sheets(mySheetName).Activate
        On Error GoTo 0
        If...
Trier par date Trier par votes
C

carlos

XLDnaute Impliqué
Supporter XLD
Bonjour Chris,
Pourtant j'arrive à ouvrir le fichier en CSV manuellement puis je peux faire deplacer ou copier vers mon classeur de destination. Je voulais juste automatiser ceci car j'ai 72 fichiers à importer.

J'ai essayé avec powerQuery mais il m'importe le fichier en le concatenant quand meme. Meme avec le séparateur de point virgule.
Bonne journée
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour carlos, chris,

Dans votre code plusieurs choses ne vont pas.

1) Remplacez :
VB: 
Set wbSource = Workbooks.Open(myPath & myFile)
par :
VB: 
Workbooks.OpenText myPath & myFile, Local:=True
Set wbSource = ActiveWorkbook
2) Remplacez tout ceci :
VB: 
wsSource.Unprotect
wsSource.Cells(1).CurrentRegion.Copy
wsSource.Range(Cells(1, 1), Cells(24, 24)).Copy
With wbDest
.Worksheets.Add After:=Worksheets(Worksheets.Count)
If IsError(Evaluate("=" & wsSource.Name & "!A1")) Then
' si la feuille n'existe pas
.ActiveSheet.Name = wsSource.Name
Else
.ActiveSheet.Name = wsSource.Name
End If
.Activate
.ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues
End With
par :
VB: 
With wbDest
    .Activate
    On Error Resume Next
    .Sheets(wsSource.Name).Activate
    On Error GoTo 0
    If ActiveSheet.Name <> wsSource.Name Then
        .Sheets.Add After:=.Sheets(.Sheets.Count)
        ActiveSheet.Name = wsSource.Name
    End If
    ActiveSheet.Cells.Clear
    wsSource.Cells(1).Resize(24, 24).Copy ActiveSheet.Cells(1)
End With
A+
 
Vote positif 0 Vote négatif
C

carlos

XLDnaute Impliqué
Supporter XLD
Bonjour Job75,
Merci pour ta proposition mais le resultatobtenu n'est pas tout à fait celui souhaité.
J'ai mis en piece jointe (onglet : Apres import) le resultat obtenu apres import avec ta macro.
J'ai aussi collé les valeurs du CSV dans le premier onglet (CSV)car je n'ai pas réussi à le deposer sur le site.
J'aimerais simplement que la feuille de destination soit la meme que celle du CSV sans cocatenage

Carlos
 

Pièces jointes

  • Fichier destination.xlsx
    430.9 KB · Affichages: 7
Vote positif 0 Vote négatif
C

carlos

XLDnaute Impliqué
Supporter XLD
Voici la macro reprise par Job75 :

Dim wbDest As Workbook, wbSource As Workbook
Dim wsDest As Worksheet, wsSource As Worksheet
Dim myFile As String, myPath As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wbDest = ThisWorkbook
Set wsDest = wbDest.Worksheets(1)
myPath = "D:\Lycée Stéphane Hessel\OneDrive - Lycée Stéphane Hessel\Karl EPS\Protocoles BGT BCP CAP 23\Import Fichiers Santorin\"
myFile = Dir(myPath & "*.csv")

Do While myFile <> ""
'''''''''''''''''''''''''
Workbooks.OpenText myPath & myFile, Local:=True
Set wbSource = ActiveWorkbook
'''''''''''''''''''''''''''''''''''''''''''''
Set wsSource = wbSource.Worksheets(Split(myFile, ".")(0))
With wbDest
.Activate
On Error Resume Next
.Sheets(wsSource.Name).Activate
On Error GoTo 0
If ActiveSheet.Name <> wsSource.Name Then
.Sheets.Add After:=.Sheets(.Sheets.Count)
ActiveSheet.Name = wsSource.Name
End If
ActiveSheet.Cells.Clear
wsSource.Cells(1).Resize(24, 24).Copy ActiveSheet.Cells(1)
End With
wbSource.Close
myFile = Dir

Loop

Set wsDest = Nothing: Set wsSource = Nothing
Set wbDest = Nothing: Set wbSource = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Ajoutez l'argument Semicolon:=True qui précise le séparateur point-virgule :
VB: 
Workbooks.OpenText myPath & myFile, Semicolon:=True, Local:=True
En général on peut s'en passer mais en effet avec votre exemple il faut le mettre.
 
Vote positif 0 Vote négatif
C

carlos

XLDnaute Impliqué
Supporter XLD
Re,
Ta proposition fonctionne avec les fichier source que que je t'ai donné mais ...
J'avais simplifié les 2 lignes de la PJ pour que ce soit plus facile mais en faite ca ne marche pas avec les données réélles que j'ai mise dans le fichier joint.
Je suis désolé.
Merci
Voici le code que j'ai mis suite à tes conseils.
Private Sub CommandButton3_Click()
Dim wbDest As Workbook, wbSource As Workbook
Dim wsDest As Worksheet, wsSource As Worksheet
Dim myFile As String, myPath As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wbDest = ThisWorkbook
Set wsDest = wbDest.Worksheets(1)
myPath = "D:\Lycée Stéphane Hessel\OneDrive - Lycée Stéphane Hessel\Karl EPS\Protocoles BGT BCP CAP 23\Import Fichiers Santorin\"
myFile = Dir(myPath & "*.csv")

Do While myFile <> ""
'''''''''''''''''''''''''
Workbooks.OpenText myPath & myFile, Semicolon:=True, Local:=True
'Workbooks.OpenText myPath & myFile, Local:=True
Set wbSource = ActiveWorkbook
'''''''''''''''''''''''''''''''''''''''''''''
Set wsSource = wbSource.Worksheets(Split(myFile, ".")(0))
With wbDest
.Activate
On Error Resume Next
.Sheets(wsSource.Name).Activate
On Error GoTo 0
If ActiveSheet.Name <> wsSource.Name Then
.Sheets.Add After:=.Sheets(.Sheets.Count)
ActiveSheet.Name = wsSource.Name
End If
ActiveSheet.Cells.Clear
wsSource.Cells(1).Resize(24, 24).Copy ActiveSheet.Cells(1)
End With
wbSource.Close
myFile = Dir

Loop

Set wsDest = Nothing: Set wsSource = Nothing
Set wbDest = Nothing: Set wbSource = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
 

Pièces jointes

  • Fichier destination (3).xlsx
    431.3 KB · Affichages: 6
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour carlos, le forum,

Pour tester j'ai créé 72 fichiers CSV : la macro du post #8 s'exécute en 23 secondes chez moi.

Pour aller vite on peut ouvrir les fichiers CSV en lecture séquentielle :
VB: 
Private Sub CommandButton2_Click()
Dim t, wbDest As Workbook, myPath$, myFile$, mySheetName$, n%, x$, s
t = Timer
Set wbDest = ThisWorkbook
'myPath = "D:\Lycée Stéphane Hessel\OneDrive - Lycée Stéphane Hessel\Karl EPS\Protocoles BGT BCP CAP 23\Import Fichiers Santorin\"
myPath = wbDest.Path & "\"
myFile = Dir(myPath & "*.csv")
Application.ScreenUpdating = False
Do While myFile <> ""
    mySheetName = Left(myFile, Len(myFile) - 4)
    n = FreeFile
    Open myPath & myFile For Input As #n 'ouverture en lecture séquentielle
    x = Input(LOF(n), #n) 'concaténation
    s = Split(x, vbCrLf) 'vecteur ligne
    Close #n
    With wbDest
        .Activate
        On Error Resume Next
        .Sheets(mySheetName).Activate
        On Error GoTo 0
        If ActiveSheet.Name <> mySheetName Then
            .Sheets.Add After:=.Sheets(.Sheets.Count)
            ActiveSheet.Name = mySheetName
        End If
        ActiveSheet.Cells.Delete
        With ActiveSheet.Cells(1).Resize(UBound(s))
            .Value = Application.Transpose(s)
            .TextToColumns .Cells, xlDelimited, Semicolon:=True 'commande Convertir
        End With
    End With
    myFile = Dir
Loop
wbDest.Sheets(1).Activate
MsgBox "Durée " & Format(Timer - t, "0.00 \sec")
End Sub
Téléchargez les fichiers zippés joints dans le même dossier et exécutez les 2 macros.

A+
 

Pièces jointes

  • Dossier.zip
    479.9 KB · Affichages: 1
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Voici une 3ème méthode, très rapide aussi, par requête QueryTables :
VB: 
Private Sub CommandButton3_Click()
Dim t, wbDest As Workbook, myPath$, myFile$, cn As Object, mySheetName$
t = Timer
Set wbDest = ThisWorkbook
'myPath = "D:\Lycée Stéphane Hessel\OneDrive - Lycée Stéphane Hessel\Karl EPS\Protocoles BGT BCP CAP 23\Import Fichiers Santorin\"
myPath = wbDest.Path & "\"
myFile = Dir(myPath & "*.csv")
Application.ScreenUpdating = False
For Each cn In wbDest.Connections: cn.Delete: Next 'supprime les connexions existantes
Do While myFile <> ""
    mySheetName = Left(myFile, Len(myFile) - 4)
    With wbDest
        .Activate
        On Error Resume Next
        .Sheets(mySheetName).Activate
        On Error GoTo 0
        If ActiveSheet.Name <> mySheetName Then
            .Sheets.Add After:=.Sheets(.Sheets.Count)
            ActiveSheet.Name = mySheetName
        End If
        ActiveSheet.Cells.Delete
        With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & myPath & myFile, Destination:=ActiveSheet.Cells(1))
            .TextFileParseType = xlDelimited
            .TextFileSemicolonDelimiter = True
            .Refresh
        End With
    End With
    myFile = Dir
Loop
wbDest.Sheets(1).Activate
MsgBox "Durée " & Format(Timer - t, "0.00 \sec")
End Sub
Edit : je supprime les connexions existantes autrement elles se cumulent.
 

Pièces jointes

  • Dossier.zip
    485.3 KB · Affichages: 8
Dernière édition:
Vote positif 0 Vote négatif
Solution

Discussions similaires

Nadou69
  • Résolu(e)
XL 2019 Erreur dans ma macro
Réponses
9
Affichages
312
Nadou69
Nadou69
O
  • Question
Microsoft 365 Excel [VBA]. Erreur d’exécution 424 Objet requis sur une concaténation
Réponses
3
Affichages
364
Oneida
Oneida
G
  • Question
Microsoft 365 Enregistrer les onglets d'un fichier Excel séparément.
Réponses
2
Affichages
411
kiki29
kiki29
G
  • Question
Microsoft 365 Saut de ligne dans une cellule
Réponses
3
Affichages
431
GClaire
G
L
  • Question
Autres Copier des données d’un fichier sans l’ouvrir juste en le sélectionnant via un UserForm
Réponses
6
Affichages
646
Liner77
L
L
  • Résolu(e)
Microsoft 365 Décompte via plusieurs fichiers CSV
Réponses
12
Affichages
591
WTF
WTF
Y
  • Résolu(e)
XL 2016 Incrémentation de valeur avec VBA
2
Réponses
24
Affichages
2 K
yapad05
Y
F
  • Résolu(e)
XL 2010 Importer des données de plusieurs fichiers sans les ouvrir
Réponses
9
Affichages
1 K
Hasco
Hasco
F
  • Question
XL 2016 Blocage macro sur instruction SET
Réponses
6
Affichages
526
job75
job75
J
  • Question
XL 2019 VBA problematique transormation xls en csv
Réponses
2
Affichages
1 K
JoyceD
J

Membres actuellement en ligne

12 membres et 134 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 705
Messages
2 112 076
Membres
111 411
dernier inscrit
NIMY