Import dữ liệu từ File đang đóng bị lỗi trường Ngày tháng năm

[Cá ngừ F1]

Tôi mở tập tin Source rồi Run cũng kết quả sai tương tự. Tất nhiên thiết lập của tôi khác của bạn.

Nhưng nếu là tập tin chuẩn thì dù đóng hay mở chưa bao giờ tôi thấy có vấn đề.

Hôm nay e chạy code import bị lỗi này: Unspecified error.
Có phải do Ram hết bộ nhớ.
Tắt hệt các File excel đi, mở lại và Import thì được.

 

[syquan]

Gửi các thành viên GPE,
Em có sử dụng Code ADO để ImPort dữ liệu từ File đang đóng. Code sưu tầm của sư phụ @ndu96081631
Mọi người giải nén Folder Import Data về máy, Click RUN để Import dữ liệu:

Có một thực trạng như sau:
(1) Tại File nguồn (Source) những bản ghi có tháng <=12 thì khi Import về File đích bị đảo vị chí thành ngày, ví dụ 03/12/2018 thành 12/03/2018.
(2) Nhưng nếu mở File Nguồn, Click RUN thì trường ngày lại đúng.

Hình như thực trạng này có nói ở đâu đó trên GPE rồi mà em mò không ra.
Rất mong mọi người hỗ trợ chỉnh sửa.

Chi tiết Code sưu tầm:

Function GetData(ByVal FileName As String, ByVal SheetName As String, ByVal RangeAddress As String, _
ByVal HasTitle As Boolean, ByVal UseTitle As Boolean)

    Dim cnn As Object, rsData As Object
    Dim tmpArr, Arr
    Dim szConn As String, szSQL As String, Tmp As String
    Dim lR As Long, lC As Long, lVersn As Long
    On Error GoTo ErrHandler
        lVersn = Val(Application.Version)
    Set cnn = CreateObject("ADODB.Connection")
    Set rsData = CreateObject("ADODB.Recordset")

    If lVersn < 12 Then
        szConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileName & ";" & _
        "Extended Properties=""Excel 8.0;HDR=" & IIf(HasTitle, "Yes", "No") & ";IMEX=1"";"
    Else
        szConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";" & _
        "Extended Properties=""Excel 12.0;HDR=" & IIf(HasTitle, "Yes", "No") & ";IMEX=1"";"
    End If
    If SheetName = "" Then
    Dim Dbs As Object, db As Object
    Set Dbs = CreateObject("DAO.DBEngine." & IIf(lVersn < 12, "36", "120"))
    Set db = Dbs.OpenDatabase(FileName, False, False, "Excel 8.0;")
    Tmp = db.TableDefs(0).Name
    Tmp = Replace(Tmp, "''", "'")
    SheetName = Tmp
    db.Close
    Set Dbs = Nothing: Set db = Nothing
    Else
    SheetName = SheetName & "$"
    End If
    cnn.Open szConn
    szSQL = "SELECT * FROM [" & SheetName & RangeAddress & "];"
    rsData.Open szSQL, cnn, 1, 1
    tmpArr = rsData.GetRows
    ReDim Arr(UBound(tmpArr, 2) - UseTitle, UBound(tmpArr, 1))
    If UseTitle Then
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
    Arr(0, lC) = rsData.Fields(lC).Name
    Next
    End If
    rsData.Close: cnn.Close
    For lR = LBound(tmpArr, 2) To UBound(tmpArr, 2)
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
    Arr(lR - UseTitle, lC) = tmpArr(lC, lR)
    Next
    Next
    GetData = Arr
    Set rsData = Nothing: Set cnn = Nothing
    Exit Function
ErrHandler:
MsgBox Err.Description
Set rsData = Nothing: Set cnn = Nothing
End Function
Sub Data()
Application.ScreenUpdating = False
  Sheet1.[A2:C5000].ClearContents
  Dim FileName As String, SheetName As String, RangeAddress As String
  Dim Arr
  FileName = ActiveWorkbook.Path & "\" & "Source.xlsm"
  SheetName = "Sheet1"
  RangeAddress = "A1:C5000"
  Arr = GetData(FileName, SheetName, RangeAddress, True, True)
    If IsArray(Arr) Then
      ThisWorkbook.Sheets("sheet1").[A1].Resize(UBound(Arr, 1) + 1, _
      UBound(Arr, 2) + 1).Value = Arr
    End If
Application.ScreenUpdating = True
End Sub
Sub Xoa()
Application.ScreenUpdating = False
Sheet1.[A2:C5000].ClearContents
Application.ScreenUpdating = True
End Sub

Của bạn đây, cái này có thể xử lý dữ liệu ngày trong file source trước
Mình làm thêm 1 nút trong file Data. Trong đó có hàm chuyển đổi dữ liệu ngày tháng trong modul1.

Private Sub CommandButton1_Click()
Dim I, J As Long
J = Sheets("Sheet1").UsedRange.Rows.Count
For I = 3 To J
If Sheets("Sheet1").Cells(I, 3).Value = "" Then
Sheets("Sheet1").Cells(I, 3).Value = ""
Else
Sheets("Sheet1").Cells(I, 3).Value = DateValue(ExtractNumber(Sheets("Sheet1").Cells(I, 3).Value))
End If
Next
End Sub

'trong modul1
' ham chuyen doi ngay thang nam
Function ExtractNumber(rCell As String)
Dim lCount As Long
Dim sText As String
Dim lNum As String
sText = rCell
For lCount = Len(sText) To 1 Step -1
If IsNumeric(Mid(sText, lCount, 1)) Then
lNum = Mid(sText, lCount, 1) & lNum
End If
Next lCount
lNum = Left(lNum, 2) & "/" & Mid(lNum, 3, 2) & "/" & Right(lNum, 4)
ExtractNumber = lNum
End Function