XL 2019 Importer fichier csv sans consatener les colonnes

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
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...

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
 

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+
 

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

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
 

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.
 

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

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:

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:

Discussions similaires

Réponses
9
Affichages
144

Membres actuellement en ligne

Aucun membre en ligne actuellement.

Statistiques des forums

Discussions
313 271
Messages
2 096 724
Membres
106 720
dernier inscrit
Alain EDZOA