Jomathr
02-18-2014, 01:05 PM
Good day everyone,
Once again I've been facing a proble I can't seem to solve, this time regarding date format on importing .CSV file to transfer data from one excel to another
here is my export code wich work fine:
Sub ExportCSV()
Dim LastRow As String
Dim sFile As String
Dim sPath As String
Dim sFullName As String
sPath = Feuil3.Range("ParamExportPath").Value
LastRow = Feuil4.Range("B65535").End(xlUp).Row
sFile = "Data_" & Format(Now, "YYYYMMDD_HHMMSS") & ".CSV"
sFullName = sPath & sFile
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo Errhandler
Feuil4.Visible = xlSheetVisible
Feuil4.Select
Range("A10:XB" & LastRow).Select
Selection.Copy
Workbooks.Add
ActiveSheet.PasteSpecial (xlPasteValuesAndNumberFormats)
Application.CutCopyMode = False
With ActiveWorkbook.WebOptions
.RelyOnCSS = True
.OrganizeInFolder = True
.UseLongFileNames = True
.DownloadComponents = False
.RelyOnVML = False
.AllowPNG = True
.ScreenSize = msoScreenSize1024x768
.PixelsPerInch = 96
.Encoding = msoEncodingUTF8
End With
With Application.DefaultWebOptions
.SaveHiddenData = True
.LoadPictures = True
.UpdateLinksOnSave = True
.CheckIfOfficeIsHTMLEditor = True
.AlwaysSaveInDefaultEncoding = False
.SaveNewWebPagesAsWebArchives = True
End With
ActiveWorkbook.SaveAs Filename:= _
sFullName, _
FileFormat:=xlCSV, CreateBackup:=False
ActiveWindow.Close
On Error GoTo 0
'Supprime les entrées dans la DB
Feuil4.Select
Feuil4.Range("A10:XB" & LastRow).ClearContents
'Feuil4.Visible = xlSheetVeryHidden
Feuil1.Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
Errhandler:
Select Case Err
Case 68, 75: ' Error 68: "Device not available"
' Error 75: "Path/File Access Error"
MsgBox "Une erreur de lecture du disque " & Mid(sPath, 1, 3) & " est survenu, l'exportation n'est pas complété"
ActiveWorkbook.Close
Feuil4.Visible = xlSheetVeryHidden
Feuil1.Select
Case 76, 1004: ' Error 76: "Path not found"
MsgBox "Le répertoire de destination est introuvable, veuillez modifier le chemin d'accès et réessayer."
ActiveWorkbook.Close
Feuil4.Visible = xlSheetVeryHidden
Feuil1.Select
Case Else: ' Erreur autre que 68, 75 or 76 has occurred.
MsgBox "Erreur # " & Err & " : " & Error(Err) & ". Some text"
Feuil4.Visible = xlSheetVeryHidden
Feuil1.Select
End Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
The format before exporting to the csv for the date column is YYYY-MM-DD and if I check directly in the created CSV it is converted to MM/DD/YYYY
now for the import code:
Sub ImportCSV()
Dim sPath As String
Dim StartLine As String
Dim sFile As String
Dim sFullName As String
sPath = Feuil3.Range("ParamExportPath").Value
sFile = Dir(sPath & "*.csv")
StartLine = Feuil4.Range("A1048576").End(xlUp).Offset(1, 0).Address
sFullName = sPath & sFile
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo Errhandler
While sFile <> ""
Feuil4.Visible = xlSheetVisible
Feuil4.Select
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & sFullName _
, Destination:=Range(StartLine))
'.CommandType = 0
'.Name = ActiveWorkbook '"CSVnow3"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 65000
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, xlYMDFormat, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
sFile = Dir
Wend
Feuil4.Range("C10,C650000").NumberFormat = "yyyy/mm/dd"
'déplace dans le sous-répertoire backup et Supprime le fichier csv
Dim d As String, ext, x
Dim destPath As String, SrcFile As String
destPath = sPath & "\Backup\"
ext = Array("*.csv")
Dim DBDataset As String
DBDataset = Feuil4.Range("XB165535").End(xlUp).Address
Feuil4.Range("A9:" & DBDataset).Name = "DataXD"
If Dir(destPath, vbDirectory) = vbNullString Then MkDir destPath 'Crée le répertoire backup si il n'existe pas
For Each x In ext
d = Dir(sPath & x)
Do While d <> ""
SrcFile = sPath & d
FileCopy SrcFile, destPath & d
Kill SrcFile
d = Dir
Loop
Next
Feuil4.Visible = xlSheetVeryHidden
Feuil1.Select
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
Errhandler:
Select Case Err
Case 68, 75: ' Error 68: "Device not available"
' Error 75: "Path/File Access Error"
MsgBox "Une erreur de lecture du disque " & Mid(sPath, 1, 3) & " est survenu, l'exportation n'est pas complété"
Feuil4.Visible = xlSheetVeryHidden
Case 76, 1004: ' Error 76: "Path not found"
MsgBox "Le répertoire d'importation est introuvable, veuillez modifier le chemin d'accès et réessayer."
Feuil4.Visible = xlSheetVeryHidden
Case 53: ' Error 53: "File not found"
MsgBox "Aucun fichier d'importation n'est présent dans le répertoire sélectionné"
Feuil4.Visible = xlSheetVeryHidden
Case Else: ' Erreur autre que 68, 75 or 76 has occurred.
MsgBox "Erreur # " & Err & " : " & Error(Err) & ". Some text"
Feuil4.Visible = xlSheetVeryHidden
End Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
the 3rs column in the array is my date column, I tried using 5, xlYMDFormat, "YYYY-MM-DD" in the .TextFileColumnDataTypes nothing will set the date in the correct format wich is suppose to be YYYY-MM-DD but I always end up with DD-MM-YYYY wich is not even the format from the cvs file.
Also, the whole column in my table that receive the dates is formated to output it in YYYY-MM-DD before import.
anyone have a clue regarding this?
Once again I've been facing a proble I can't seem to solve, this time regarding date format on importing .CSV file to transfer data from one excel to another
here is my export code wich work fine:
Sub ExportCSV()
Dim LastRow As String
Dim sFile As String
Dim sPath As String
Dim sFullName As String
sPath = Feuil3.Range("ParamExportPath").Value
LastRow = Feuil4.Range("B65535").End(xlUp).Row
sFile = "Data_" & Format(Now, "YYYYMMDD_HHMMSS") & ".CSV"
sFullName = sPath & sFile
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo Errhandler
Feuil4.Visible = xlSheetVisible
Feuil4.Select
Range("A10:XB" & LastRow).Select
Selection.Copy
Workbooks.Add
ActiveSheet.PasteSpecial (xlPasteValuesAndNumberFormats)
Application.CutCopyMode = False
With ActiveWorkbook.WebOptions
.RelyOnCSS = True
.OrganizeInFolder = True
.UseLongFileNames = True
.DownloadComponents = False
.RelyOnVML = False
.AllowPNG = True
.ScreenSize = msoScreenSize1024x768
.PixelsPerInch = 96
.Encoding = msoEncodingUTF8
End With
With Application.DefaultWebOptions
.SaveHiddenData = True
.LoadPictures = True
.UpdateLinksOnSave = True
.CheckIfOfficeIsHTMLEditor = True
.AlwaysSaveInDefaultEncoding = False
.SaveNewWebPagesAsWebArchives = True
End With
ActiveWorkbook.SaveAs Filename:= _
sFullName, _
FileFormat:=xlCSV, CreateBackup:=False
ActiveWindow.Close
On Error GoTo 0
'Supprime les entrées dans la DB
Feuil4.Select
Feuil4.Range("A10:XB" & LastRow).ClearContents
'Feuil4.Visible = xlSheetVeryHidden
Feuil1.Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
Errhandler:
Select Case Err
Case 68, 75: ' Error 68: "Device not available"
' Error 75: "Path/File Access Error"
MsgBox "Une erreur de lecture du disque " & Mid(sPath, 1, 3) & " est survenu, l'exportation n'est pas complété"
ActiveWorkbook.Close
Feuil4.Visible = xlSheetVeryHidden
Feuil1.Select
Case 76, 1004: ' Error 76: "Path not found"
MsgBox "Le répertoire de destination est introuvable, veuillez modifier le chemin d'accès et réessayer."
ActiveWorkbook.Close
Feuil4.Visible = xlSheetVeryHidden
Feuil1.Select
Case Else: ' Erreur autre que 68, 75 or 76 has occurred.
MsgBox "Erreur # " & Err & " : " & Error(Err) & ". Some text"
Feuil4.Visible = xlSheetVeryHidden
Feuil1.Select
End Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
The format before exporting to the csv for the date column is YYYY-MM-DD and if I check directly in the created CSV it is converted to MM/DD/YYYY
now for the import code:
Sub ImportCSV()
Dim sPath As String
Dim StartLine As String
Dim sFile As String
Dim sFullName As String
sPath = Feuil3.Range("ParamExportPath").Value
sFile = Dir(sPath & "*.csv")
StartLine = Feuil4.Range("A1048576").End(xlUp).Offset(1, 0).Address
sFullName = sPath & sFile
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo Errhandler
While sFile <> ""
Feuil4.Visible = xlSheetVisible
Feuil4.Select
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & sFullName _
, Destination:=Range(StartLine))
'.CommandType = 0
'.Name = ActiveWorkbook '"CSVnow3"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 65000
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, xlYMDFormat, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
sFile = Dir
Wend
Feuil4.Range("C10,C650000").NumberFormat = "yyyy/mm/dd"
'déplace dans le sous-répertoire backup et Supprime le fichier csv
Dim d As String, ext, x
Dim destPath As String, SrcFile As String
destPath = sPath & "\Backup\"
ext = Array("*.csv")
Dim DBDataset As String
DBDataset = Feuil4.Range("XB165535").End(xlUp).Address
Feuil4.Range("A9:" & DBDataset).Name = "DataXD"
If Dir(destPath, vbDirectory) = vbNullString Then MkDir destPath 'Crée le répertoire backup si il n'existe pas
For Each x In ext
d = Dir(sPath & x)
Do While d <> ""
SrcFile = sPath & d
FileCopy SrcFile, destPath & d
Kill SrcFile
d = Dir
Loop
Next
Feuil4.Visible = xlSheetVeryHidden
Feuil1.Select
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
Errhandler:
Select Case Err
Case 68, 75: ' Error 68: "Device not available"
' Error 75: "Path/File Access Error"
MsgBox "Une erreur de lecture du disque " & Mid(sPath, 1, 3) & " est survenu, l'exportation n'est pas complété"
Feuil4.Visible = xlSheetVeryHidden
Case 76, 1004: ' Error 76: "Path not found"
MsgBox "Le répertoire d'importation est introuvable, veuillez modifier le chemin d'accès et réessayer."
Feuil4.Visible = xlSheetVeryHidden
Case 53: ' Error 53: "File not found"
MsgBox "Aucun fichier d'importation n'est présent dans le répertoire sélectionné"
Feuil4.Visible = xlSheetVeryHidden
Case Else: ' Erreur autre que 68, 75 or 76 has occurred.
MsgBox "Erreur # " & Err & " : " & Error(Err) & ". Some text"
Feuil4.Visible = xlSheetVeryHidden
End Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
the 3rs column in the array is my date column, I tried using 5, xlYMDFormat, "YYYY-MM-DD" in the .TextFileColumnDataTypes nothing will set the date in the correct format wich is suppose to be YYYY-MM-DD but I always end up with DD-MM-YYYY wich is not even the format from the cvs file.
Also, the whole column in my table that receive the dates is formated to output it in YYYY-MM-DD before import.
anyone have a clue regarding this?