XL 2013 Transformer le format Texte en Date suite à un transfert automatique via VBA

MgLina

XLDnaute Nouveau
Bonjour le Forum!

J'avais crée une discussion pour importer et transférer les données automatiquement via VBA, et suite à des recherches dans le forum, j'ai réussi à combiner les différentes solutions pour résoudre mon problème.

Par contre, j'ai rencontré deux problèmes:
1. Le transfert de données automatisé fonctionne bien, mais je n'ai pas le bon format. Par exemple, les données en date sont transférées en Texte (colonne H, I, J, K).
2. Le temps d'exécution est long!, ça me prend plus de 2 mins pour ce tableau de test, mais le fichier que je dois travailler peut avoir plus de milliers de lignes. Je ne veut pas passer des heures pour faire le transfert. SVP! Help!

Voici le code que j'ai utilisé:
VB:
Sub Importer()
Dim nom$, WBKSource As Workbook
With Application.FileDialog(msoFileDialogOpen)
   .Title = "Veuillez sélectionner le fichier"
    .Filters.Clear
    .Filters.Add "RECAP", "*.xlsX*, *.Xlsm*, *.Xls*"
    .AllowMultiSelect = False
        If .Show <> 0 Then
        nom = .SelectedItems(1)
            Set WBKSource = Workbooks.Open(nom)
           With WBKSource
                .ActiveSheet.Copy Before:=ThisWorkbook.Sheets(1)
                .Close False
            End With
        Else
        MsgBox "Aucun fichier sélectionné": Exit Sub
        End If
End With

End Sub
Sub Transférer()
Application.ScreenUpdating = False
DL1 = Sheets("Gantt Chart").Range("A6000").End(xlUp).Row
DL2 = Sheets("Gantt Chart (2)").Range("A6000").End(xlUp).Row
Set F = Sheets("Gantt Chart (2)")
With Sheets("Gantt Chart")
    For L = 5 To DL2
        If Application.CountIf(.Range("AA:AA"), F.Cells(L, "AA")) = 0 Then ' Le code n'existe pas
            DL1 = DL1 + 1                                               ' Incrément N° ligne de transfert
            Copie DL1, L
        Else
            Lx = Application.Match(F.Cells(L, "AA"), .Range("AA:AA"), 0)   ' Ligne où se trouve le code
            Copie Lx, L
        End If
    Next L
End With
End Sub
Sub Copie(Li1, Li2) ' Transfert cellules
    Set F = Sheets("Gantt Chart (2)")
    With Sheets("Gantt Chart")
        .Cells(Li1, "A") = F.Cells(Li2, "A")
        .Cells(Li1, "B") = F.Cells(Li2, "B")
        .Cells(Li1, "C") = F.Cells(Li2, "C")
        .Cells(Li1, "D") = F.Cells(Li2, "D")
        .Cells(Li1, "E") = F.Cells(Li2, "E")
        .Cells(Li1, "F") = F.Cells(Li2, "F")
        .Cells(Li1, "G") = F.Cells(Li2, "G")
        .Cells(Li1, "H") = F.Cells(Li2, "H")
        .Cells(Li1, "I") = F.Cells(Li2, "I")
        .Cells(Li1, "J") = F.Cells(Li2, "J")
        .Cells(Li1, "K") = F.Cells(Li2, "K")
        .Cells(Li1, "L") = F.Cells(Li2, "L")
        .Cells(Li1, "M") = F.Cells(Li2, "M")
        .Cells(Li1, "N") = F.Cells(Li2, "N")
        .Cells(Li1, "Z") = F.Cells(Li2, "Z")
        .Cells(Li1, "AA") = F.Cells(Li2, "AA")
    End With
End Sub

Pourriez-vous svp m'aider à améliorer le code ? Voici la capture d'écran une fois que j'ai fait le transfert. J'aimerais que les lignes transférées 28 à 32 aient le même format que les autres lignes. Et je voudrais réduire le temps d'exécution de transfert.
1617033893464.png


Je vous remercie énormément!
 

Pièces jointes

  • Fichier A-Fichier origine.xlsx
    51.8 KB · Affichages: 2
Dernière édition:

Discussions similaires

Haut Bas