VBA Format date lors d'importation

Bonjour au forum,

Je souhaite forcer le format de cellules d'une colonne en format date pour pouvoir les exploiter dans un TCD.

Les données sont importées quotidiennement d'un fichier .xls (Liste à impoter.xls ci-joint) où les cellules des colonnes contenant les dates sont bien en format date (colonnes B et H, toutes sont bien sur la droite de la cellule).

Lorsque l'import est effectué dans le fichier de destination via le bouton "Import de données" (fichier CTS_fof.xlsm ci-joint), les dates des colonnes A et G sont à droite de la cellule pour certaines, et d'autres sont à gauche, et ne sont donc pas exploitables dans un TCD.

En forçant le format de ces cellules en format date via :

.Range("A11:A" & dl3).NumberFormat = "dd/mm/yyyy"

le problème persiste...

J'ai testé avec "m/d/yyyy", "mm/dd/yyyy", "jj/mm/aaaa", etc. mais rien n'y fait...

Que puis-je faire pour avoir ces cellules en format date ?

Merci d'avance

28cts-fof.xlsm (37.65 Ko)

Bonjour

Le problème est que ton fichier à importer n'est pas un fichier excel, c'est un fichier texte dont on a changé l'extension.

capture d ecran 451

Ouvre le fichier, enregistre le proprement en xlsx et ensuite l'importation, se fera correctement sans même avoir à écrire ces lignes :

        '.Range("A11:A" & dl3).NumberFormat = "dd/mm/yyyy"
        '.Range("G11:G" & dl3).NumberFormat = "dd/mm/yyyy"

Fais l'essai avec ce fichier qui est le tien au format excel !

Bonsoir,

Autre solution, tout en gardant le format de ton fichier "source"

remplace la mise au format "dd/mm/yyyy" ou tout autre format par une conversion (du ruban "Données/Convertir")

Style :

Sub Copy()

    Dim dl1 As Long, dl2 As Long, dl3 As Long 'déclaration des dernières lignes
    Dim wb1 As Workbook, wb2 As Workbook 'déclaration des classeurs
    Dim ws1 As Worksheet, ws2 As Worksheet 'déclaration des feuilles

On Error GoTo Erreur 'si erreur, va directement à Erreur en fin de code

    ChDrive "C"
    ChDir "C:\Users\*********\Documents\Excel\Nico xld" 'chemin par défaut

    Set wb1 = ThisWorkbook 'définition du classeur 1 (ce classeur)
    Set ws1 = wb1.Sheets("Import") 'définition de la feuille 1 (Import de ce classeur)
    Set wb2 = Workbooks.Open(Application.GetOpenFilename) 'définition du classeur 2 (classeur à importer)
    Set ws2 = wb2.Worksheets(1) 'définition de la feuille 2 (1er feuille du classeur à importer)

    dl1 = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    dl2 = ws2.Range("A" & Rows.Count).End(xlUp).Row

If MsgBox("Voulez-vous réellement importer des données de donneurs ?", vbExclamation + vbYesNo, "Importer ?") = vbNo Then
    wb2.Close False
Exit Sub

Else:

Application.ScreenUpdating = False

    ws1.Unprotect ""
    ws2.Range("B2:J" & dl2).Copy ws1.Range("A" & dl1)
    wb2.Close False

    With ws1

    dl3 = ws1.Range("A" & Rows.Count).End(xlUp).Row
        .Range("A11:A" & dl3).TextToColumns Destination:=.Range("A11:A" & dl3), FieldInfo:=Array(1, 4)
        .Range("G11:G" & dl3).TextToColumns Destination:=.Range("G11:G" & dl3), FieldInfo:=Array(1, 4)
        .Range("A11:I" & dl3).Borders.Value = 1
        .Range("A11:I" & dl3).Borders(xlEdgeLeft).Weight = xlThick
        .Range("A11:I" & dl3).Borders(xlEdgeRight).Weight = xlThick
        .Range("A11:I" & dl3).Borders(xlEdgeTop).Weight = xlMedium
        .Range("A11:I" & dl3).Borders(xlEdgeBottom).Weight = xlThick
        .Range("A11:I" & dl3).Locked = True
        .Protect "", True, True, False, AllowFormattingCells:=True, _
            AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
    End With
End If

Application.ScreenUpdating = True

Exit Sub 'Permet de sortir de la procédure et évite la gestion d'erreur (Erreur), si la macro
's'est déroulée sans encombre.
Erreur:
MsgBox "Aucun fichier sélectionné !", vbExclamation, "Annulation !"
ws1.Protect "", True, True, False, AllowFormattingCells:=True, _
            AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
End Sub

Peut-être?

Bonne soirée

Merci pour vos réponses

@Steelson, effectivement, merci beaucoup... J'aimerais pouvoir faire cette conversion via la macro, mais j'ai du mal à trouver une solution

Sub Copy()

    Dim dl1 As Long, dl2 As Long, dl3 As Long 'déclaration des dernières lignes
    Dim wb1 As Workbook, wb2 As Workbook 'déclaration des classeurs
    Dim ws1 As Worksheet, ws2 As Worksheet 'déclaration des feuilles
    Dim Chemin As String, Fichier As String

On Error GoTo Erreur 'si erreur, va directement à Erreur en fin de code

    ChDrive "P"
    ChDir "P:\MGL-SHARE\Labo LIHT\NREV\Statistiques\CTS\" 'chemin par défaut

    Set wb1 = ThisWorkbook 'définition du classeur 1 (ce classeur)
    Set ws1 = wb1.Sheets("Import") 'définition de la feuille 1 (Import de ce classeur)
    Set wb2 = Workbooks.Open(Application.GetOpenFilename) 'définition du classeur 2 (classeur à importer)
    Set ws2 = wb2.Worksheets(1) 'définition de la feuille 2 (1er feuille du classeur à importer)

    dl1 = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    dl2 = ws2.Range("A" & Rows.Count).End(xlUp).Row

If MsgBox("Voulez-vous réellement importer des données de donneurs ?", vbExclamation + vbYesNo, "Importer ?") = vbNo Then
    wb2.Close False
Exit Sub

Else:

Application.ScreenUpdating = False

Chemin = "P:\MGL-SHARE\Labo LIHT\NREV\Statistiques\CTS\Extraction\"
Fichier = "Extraction_" & Format(Date, "yyyy.mm.dd") & ".xlsx"

    ws1.Unprotect ""
    wb2.SaveAs Chemin & Fichier, FileFormat:=xlOpenXMLWorkbook
    ws2.Range("B2:J" & dl2).Copy
    ws1.Range("A" & dl1).PasteSpecial Paste:=xlPasteValues
    wb2.Close False

    With ws1

    dl3 = ws1.Range("A" & Rows.Count).End(xlUp).Row

        .Range("A11:A" & dl3).NumberFormat = "dd/mm/yyyy"
        .Range("B11:B" & dl3).NumberFormat = "@"
        .Range("C11:C" & dl3).NumberFormat = "@"
        .Range("D11:D" & dl3).NumberFormat = "@"
        .Range("E11:E" & dl3).NumberFormat = "0"
        .Range("F11:F" & dl3).NumberFormat = "@"
        .Range("G11:G" & dl3).NumberFormat = "dd/mm/yyyy"
        .Range("H11:H" & dl3).NumberFormat = "@"
        .Range("I11:I" & dl3).NumberFormat = "@"
        .Range("A11:I" & dl3).Borders.Value = 1
        .Range("A11:I" & dl3).Borders(xlEdgeLeft).Weight = xlThick
        .Range("A11:I" & dl3).Borders(xlEdgeRight).Weight = xlThick
        .Range("A11:I" & dl3).Borders(xlEdgeTop).Weight = xlMedium
        .Range("A11:I" & dl3).Borders(xlEdgeBottom).Weight = xlThick
        .Range("A11:I" & dl3).Locked = True
        .Protect "", True, True, False, AllowFormattingCells:=True, _
            AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
    End With
End If

Application.ScreenUpdating = True

Exit Sub 'Permet de sortir de la procédure et évite la gestion d'erreur (Erreur), si la macro
's'est déroulée sans encombre.
Erreur:
MsgBox "Aucun fichier sélectionné !", vbExclamation, "Annulation !"
ws1.Protect "", True, True, False, AllowFormattingCells:=True, _
            AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
End Sub

En l'état actuel, j'imagine que ça ne fonctionne pas car la variable wb2 concerne le classeur AVANT l'enregistrement... Comment pourrais-je contourner ce problème ?

Pour info, le fichier de départ qui est donc de format texte peut être supprimé une fois qu'il a été sauvegarder dans le bon format.

Merci d'avance pour votre aide !

@Steelson, effectivement, merci beaucoup... J'aimerais pouvoir faire cette conversion via la macro, mais j'ai du mal à trouver une solution

1- as-tu essayé la solution de cousinhub ?

2- as-tu la possibilité au préalable d'ouvrir et enregistrer proprement le fichier en xlsx comme je l'avais fait ?

question subsidiaire : qui/quel logiciel se permet d'enregistrer un fichier texte directement en xls ?

1- as-tu essayé la solution de cousinhub ?

Oui mais la solution ne me conviens pas, j'ai besoin de garder le fichier à importer dans le bon format, donc en .xlsx.

2- as-tu la possibilité au préalable d'ouvrir et enregistrer proprement le fichier en xlsx comme je l'avais fait ?

C'est justement ce que j'aimerais pouvoir faire via la macro, puis supprimer le fichier à importer qui est au mauvais format (les importations se feront quotidiennement par des utilisateurs qui ne maîtrisent pas du tout Excel)

question subsidiaire : qui/quel logiciel se permet d'enregistrer un fichier texte directement en xls ?

C'est un logiciel utilisé par une majorité des hôpitaux qui travaillent sur des banques de sang, donc impossible de modifier quoique ce soit de ce côté là...

Merci pour ton aide

PS :

J'ai encore essayé cette alternative mais je me retrouve encore avec les dates sur le côté gauche dans le fichier de destination, donc qui ne sont pas des dates...

Sub Copy()

    Dim dl1 As Long, dl2 As Long, dl3 As Long 'déclaration des dernières lignes
    Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook 'déclaration des classeurs
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet 'déclaration des feuilles
    Dim Chemin As String, Fichier As String, Suppr As String

'On Error GoTo Erreur 'si erreur, va directement à Erreur en fin de code

    ChDrive "P"
    ChDir "P:\MGL-SHARE\Labo LIHT\NREV\Statistiques\CTS\" 'chemin par défaut

    Set wb1 = ThisWorkbook 'définition du classeur 1 (ce classeur)
    Set ws1 = wb1.Sheets("Import") 'définition de la feuille 1 (Import de ce classeur)
    Set wb2 = Workbooks.Open(Application.GetOpenFilename) 'définition du classeur 2 (classeur à importer)

    dl1 = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1

If MsgBox("Voulez-vous réellement importer des données de donneurs ?", vbExclamation + vbYesNo, "Importer ?") = vbNo Then
    wb2.Close False
Exit Sub

Else:

Application.ScreenUpdating = False

Chemin = "P:\MGL-SHARE\Labo LIHT\NREV\Statistiques\CTS\Extraction\"
Fichier = "Extraction_" & Format(Date, "yyyy.mm.dd") & ".xlsx"

    ws1.Unprotect ""
    wb2.SaveAs Chemin & Fichier, FileFormat:=xlOpenXMLWorkbook

    Set wb3 = ActiveWorkbook
    Set ws3 = wb3.Worksheets(1) 'définition de la feuille 2 (1er feuille du classeur à importer)
    dl2 = ws3.Range("A" & Rows.Count).End(xlUp).Row

    ws3.Range("B2:J" & dl2).Copy
    ws1.Range("A" & dl1).PasteSpecial Paste:=xlPasteValues
    wb3.Close False

    Suppr = Dir("P:\MGL-SHARE\Labo LIHT\NREV\Statistiques\CTS\Extraction\*.xls")
    Do While Suppr <> ""
        Kill "P:\MGL-SHARE\Labo LIHT\NREV\Statistiques\CTS\Extraction\" & Suppr
        Suppr = Dir
    Loop

    With ws1

    dl3 = ws1.Range("A" & Rows.Count).End(xlUp).Row

        .Range("A11:A" & dl3).NumberFormat = "dd/mm/yyyy"
        .Range("B11:B" & dl3).NumberFormat = "@"
        .Range("C11:C" & dl3).NumberFormat = "@"
        .Range("D11:D" & dl3).NumberFormat = "@"
        .Range("E11:E" & dl3).NumberFormat = "0"
        .Range("F11:F" & dl3).NumberFormat = "@"
        .Range("G11:G" & dl3).NumberFormat = "dd/mm/yyyy"
        .Range("H11:H" & dl3).NumberFormat = "@"
        .Range("I11:I" & dl3).NumberFormat = "@"
        .Range("A11:I" & dl3).Borders.Value = 1
        .Range("A11:I" & dl3).Borders(xlEdgeLeft).Weight = xlThick
        .Range("A11:I" & dl3).Borders(xlEdgeRight).Weight = xlThick
        .Range("A11:I" & dl3).Borders(xlEdgeTop).Weight = xlMedium
        .Range("A11:I" & dl3).Borders(xlEdgeBottom).Weight = xlThick
        .Range("A11:I" & dl3).Locked = True
        .Protect "", True, True, False, AllowFormattingCells:=True, _
            AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
    End With
End If

Application.ScreenUpdating = True

Exit Sub 'Permet de sortir de la procédure et évite la gestion d'erreur (Erreur), si la macro
's'est déroulée sans encombre.
Erreur:
MsgBox "Aucun fichier sélectionné !", vbExclamation, "Annulation !"
ws1.Protect "", True, True, False, AllowFormattingCells:=True, _
            AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
End Sub

Après une longue recherche, je suis parti dans une autre direction ... lecture d'un fichier texte pas à pas, recherche des tabulations et transformation des dates à partir du texte

Sub lire()

    Fichier = Application.GetOpenFilename("Fichiers faux XLS, *.XLS")
    If Fichier = False Then Exit Sub

    N = FreeFile
    Open Fichier For Input As #N

    i = 9
    Cells.ClearContents
    Do While Not EOF(1)
        Line Input #N, Contenu
        i = i + 1
        j = 0
        flag2 = True: flag8 = True
        For k = 1 To Len(Contenu)
            If Asc(Mid(Contenu, k, 1)) = 9 Then
                If i > 10 And (j = 8) And flag8 Then
                    Cells(i, j).Value = DateSerial(Mid(Cells(i, j).Value, 8, 4), Mid(Cells(i, j).Value, 5, 2), Mid(Cells(i, j).Value, 2, 2))
                    flag8 = False
                End If
                If i > 10 And (j = 2) And flag2 Then
                    Cells(i, j).Value = DateSerial(Mid(Cells(i, j).Value, 8, 4), Mid(Cells(i, j).Value, 5, 2), Mid(Cells(i, j).Value, 2, 2))
                    flag2 = False
                End If
                j = j + 1
            End If
            Cells(i, j + 1).Value = Cells(i, j + 1).Value & (Mid(Contenu, k, 1))
        Next k
    Loop

    Close #N

End Sub
10cts-fof.xlsm (35.46 Ko)

Ouuuffffff

Alors là, tu m'as complètement perdu

Si par hasard tu as le temps ET l'envie, pourrais-tu m'expliquer le code ?

Merci infiniment pour ton implication, j'ai besoin de ce fichier assez rapidement car nous devons l'utiliser dans mon service pour la gestion des Covid-19, et je t'avoue que je n'ai pas trop le temps de développer tout ceci... Donc merci encore

Je te laisse "habiller" le code avec les autres formats (si vraiment nécessaire) et la protection de la feuille.

Explications ...

J'ouvre de façon classique le fichier en texte

Open Fichier For Input As #N

Tant que je ne suis pas à la fin (EndOfFile), je lis le Contenu ligne par ligne

    Do While Not EOF(1)
        Line Input #N, Contenu

ce qui est tout à fait classique aussi sur les fichiers texte

Ensuite je décompose tous les caractères de Contenu et je cherche une tabulation (n° ascii 9)

        For k = 1 To Len(Contenu)
            If Asc(Mid(Contenu, k, 1)) = 9 Then

A ce moment là

  • je change de colonne
  • et quand les colonnes de date sont lues (en texte), je reviens une fois dessus (d'où les flags pour ne pas répéter l'opération), je décompose le texte en année, mois, jour par mid et je crée la date par DateErial(année,mois,jour)... sauf pour l'en-tête sinon cela plante ! d'où le i>10

Plus simple et plus rapide

Sub lire()
Dim i%, j%
    Fichier = Application.GetOpenFilename("Fichiers faux XLS, *.XLS")
    If Fichier = False Then Exit Sub

    N = FreeFile
    Open Fichier For Input As #N

    i = 9
    Cells.ClearContents
    Do While Not EOF(1)
        Line Input #N, Contenu
        i = i + 1
        tbl = Split(Contenu, Chr(9))
        Cells(i, 1).Resize(1, UBound(tbl) + 1) = tbl
        If i > 10 Then
            ladate i, 2
            ladate i, 8
        End If
    Loop

    Close #N

End Sub

Sub ladate(ligne%, colonne%)
    Cells(ligne, colonne).Value = DateSerial(Mid(Cells(ligne, colonne).Value, 7, 4), Mid(Cells(ligne, colonne).Value, 4, 2), Mid(Cells(ligne, colonne).Value, 1, 2))
End Sub

Impressionnant... Merci infiniment Steelson !

Je m'excuse pour le temps de réponse, c'est un peu compliqué à l'hôpital ces temps...

Si je peux me permettre d'abuser de ton temps et de ton talent, pourrais-tu me proposer tout de même un code qui me permettrait de sauvegarder un "faux" fichier Excel (comme dans cet exemple, un .txt enregistré en .xls par le programme) en un fichier exploitable .xlsx ?

C'est un logiciel que je dois utiliser très fréquemment et je rencontre donc régulierement ce problème... Cela m'aiderait beaucoup !

Merci à toi si tu acceptes !

Sub transformer()
Dim i%, j%
Dim xl As Excel.Application, wb As Workbook

    fichier = Application.GetOpenFilename("Fichiers faux XLS, *.XLS")
    If fichier = False Then Exit Sub

    N = FreeFile
    Open fichier For Input As #N

    i = 2 ' ligne début
    flagDate = False
    Set xl = CreateObject("Excel.Application")
    xl.SheetsInNewWorkbook = 1
    Set wb = xl.Workbooks.Add
    With wb.Sheets(1)
        Do While Not EOF(1)
            Line Input #N, Contenu
            tbl = Split(Contenu, Chr(9))
            .Cells(i, 1).Resize(1, UBound(tbl) + 1) = tbl
            If flagDate Then ' sup à la première ligne
                .Cells(i, 2).Value = DateSerial(Mid(.Cells(i, 2).Value, 7, 4), Mid(.Cells(i, 2).Value, 4, 2), Mid(.Cells(i, 2).Value, 1, 2))
                .Cells(i, 8).Value = DateSerial(Mid(.Cells(i, 8).Value, 7, 4), Mid(.Cells(i, 8).Value, 4, 2), Mid(.Cells(i, 8).Value, 1, 2))
            End If
            i = i + 1
            flagDate = True
        Loop
    End With

    Close #N

    wb.SaveAs Split(fichier, ".")(0) & ".xlsx"
    Set wb = Nothing
    xl.Quit
    Set xl = Nothing

    MsgBox "Terminé !"

End Sub

Bonjour Steelson,

Merci beaucoup pour ton aide, c'est super

Pour pouvoir limiter au maximum les manipulations des futurs utilisateurs du fichier (qui devront faire une extraction par jour sur toute l'année, avec une moyenne de 150 lignes par jour), j'ai "intégré" la procédure de conversion du faux fichier .xls dans la procédure générale.

Pour résumer, l'utilisateur enregistre le faux fichier .xls à partir du programme de l'hôpital dans un dossier "Données brutes". Grâce à ton code de conversion, celui-ci est convertit en .xlsx dans un dossier "Extraction". Ensuite, la procédure continue, le faux fichier .xls d'origine est supprimé, puis l'utilisateur doit ensuite sélectionner le fichier nouvellement convertit pour que l'import se fasse proprement.

Sub Copy()

    Dim dl1 As Long, dl2 As Long, dl3 As Long 'déclaration des dernières lignes
    Dim wb1 As Workbook, wb2 As Workbook 'déclaration des classeurs
    Dim ws1 As Worksheet, ws2 As Worksheet 'déclaration des feuilles
    Dim Suppr As String

    Call transformer

    Suppr = Dir("C:\Users\nico\Desktop\cts\Données brutes\*.xls")
    Do While Suppr <> ""
        Kill "C:\Users\nico\Desktop\cts\Données brutes\" & Suppr
        Suppr = Dir
    Loop

On Error GoTo Erreur 'si erreur, va directement à Erreur en fin de code

    ChDrive "C"
    ChDir "C:\Users\nico\Desktop\cts\Extraction\" 'chemin par défaut

    Set wb1 = ThisWorkbook 'définition du classeur 1 (ce classeur)
    Set ws1 = wb1.Sheets("Import") 'définition de la feuille 1 (Import de ce classeur)
    Set wb2 = Workbooks.Open(Application.GetOpenFilename) 'définition du classeur 2 (classeur à importer)
    Set ws2 = wb2.Worksheets(1) 'définition de la feuille 2 (1er feuille du classeur à importer)

    dl1 = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    dl2 = ws2.Range("A" & Rows.Count).End(xlUp).Row

If MsgBox("Voulez-vous réellement importer des données de donneurs ?", vbExclamation + vbYesNo, "Importer ?") = vbNo Then
    wb2.Close False
Exit Sub

Else:

Application.ScreenUpdating = False

    ws1.Unprotect ""
    ws2.Range("B2:J" & dl2).Copy
    ws1.Range("A" & dl1).PasteSpecial Paste:=xlPasteValues
    wb2.Close False

    With ws1

    dl3 = ws1.Range("A" & Rows.Count).End(xlUp).Row

        .Range("A11:A" & dl3).NumberFormat = "dd/mm/yyyy"
        .Range("B11:B" & dl3).NumberFormat = "@"
        .Range("C11:C" & dl3).NumberFormat = "@"
        .Range("D11:D" & dl3).NumberFormat = "@"
        .Range("E11:E" & dl3).NumberFormat = "0"
        .Range("F11:F" & dl3).NumberFormat = "@"
        .Range("G11:G" & dl3).NumberFormat = "dd/mm/yyyy"
        .Range("H11:H" & dl3).NumberFormat = "@"
        .Range("I11:I" & dl3).NumberFormat = "@"
        .Range("A11:I" & dl3).WrapText = True
        .Range("A11:I" & dl3).HorizontalAlignment = xlCenter
        .Range("A11:I" & dl3).VerticalAlignment = xlCenter
        .Range("A11:I" & dl3).Borders.Value = 1
        .Range("A11:I" & dl3).Borders(xlEdgeLeft).Weight = xlThick
        .Range("A11:I" & dl3).Borders(xlEdgeRight).Weight = xlThick
        .Range("A11:I" & dl3).Borders(xlEdgeTop).Weight = xlMedium
        .Range("A11:I" & dl3).Borders(xlEdgeBottom).Weight = xlThick
        .Range("A11:I" & dl3).Locked = True
        .Protect "", True, True, False, AllowFormattingCells:=True, _
            AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
    End With
End If

Application.ScreenUpdating = True

Exit Sub 'Permet de sortir de la procédure et évite la gestion d'erreur (Erreur), si la macro
's'est déroulée sans encombre.
Erreur:
MsgBox "Aucun fichier sélectionné !", vbExclamation, "Annulation !"
ws1.Protect "", True, True, False, AllowFormattingCells:=True, _
            AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
End Sub

Sub transformer()

Dim i%, j%
Dim xl As Excel.Application, wb As Workbook
Dim Fichier
Dim N
Dim flagDate
Dim Contenu
Dim tbl

ChDrive "C"
ChDir "C:\Users\nico\Desktop\cts\Données brutes\" 'chemin par défaut

    Fichier = Application.GetOpenFilename '("Fichiers faux XLS, *.XLS")
    If Fichier = False Then Exit Sub

    N = FreeFile
    Open Fichier For Input As #N

    i = 1 ' ligne début
    flagDate = False
    Set xl = CreateObject("Excel.Application")
    xl.SheetsInNewWorkbook = 1
    Set wb = xl.Workbooks.Add
    With wb.Sheets(1)
        Do While Not EOF(1)
            Line Input #N, Contenu
            tbl = Split(Contenu, Chr(9))
            .Cells(i, 1).Resize(1, UBound(tbl) + 1) = tbl
            If flagDate Then ' sup à la première ligne
                .Cells(i, 2).Value = DateSerial(Mid(.Cells(i, 2).Value, 7, 4), Mid(.Cells(i, 2).Value, 4, 2), Mid(.Cells(i, 2).Value, 1, 2))
                .Cells(i, 8).Value = DateSerial(Mid(.Cells(i, 8).Value, 7, 4), Mid(.Cells(i, 8).Value, 4, 2), Mid(.Cells(i, 8).Value, 1, 2))
            End If
            i = i + 1
            flagDate = True
        Loop
    End With

    Close #N

    wb.SaveAs Filename:="C:\Users\nico\Desktop\cts\Extraction\" & "Extraction_" & Format(Date, "yyyy.mm.dd") & ".xlsx"
    Set wb = Nothing
    xl.Quit
    Set xl = Nothing

    MsgBox "Conversion de fichier terminée, veuillez sélectionner maintenant le fichier au format .xlsx à importer !", vbExclamation, "Conversion terminée !"

End Sub

Cela fonctionne, penses-tu que c'est une bonne solution ?

Ci-joint les fichiers pour tester, si tu y vois une amélioration possible...

PS : avec Option Explicit, les variables Fichier, N, flagDate, Contenu et tbl me donnent une erreur donc j'ai juste mis "Dim", sans trop savoir quel type de variable c'était...

PS 2 : j'ai remarqué également qu'à force de faire des tests, même en effaçant les données de toutes les cellules de la feuille "Import", la taille de mon fichier devient énorme (il faisait 28Mo après une dizaine de tests), j'ai été obligé du supprimer la feuille "Import" et d'en créer une nouvelle pour diminuer la taille du fichier et pouvoir l'envoyer...

Merci encore pour tout !

8a-importer-fof.xls (11.39 Ko)
4cts-fof.xlsm (19.39 Ko)

Désolé, trop d'erreurs chez moi ... même après changement du répertoire.

capture d ecran 466

Pour la taille du fichier ... est-ce que le faux fichier xls a pléthore de lignes blanches en fin de fichier ?

Je viens de refaire des essais multiples avec les fichiers que j'ai conservés, pas d'allongement du fichier.

Re,

J'ai ré-uploadé le fichier sans les "Dir", tu ne devrais plus avoir d'erreur normalement...

Concernant la taille du fichier, apparemment le faux fichier ne contient pas de lignes vides. J'ai rajouté une procédure pour vider le presse papier et vider le cache des TCD, ça m'a l'air plutôt bien pour le moment...

6cts-fof1.xlsm (19.48 Ko)

Merci pour le lien, efficace !

Rechercher des sujets similaires à "vba format date lors importation"