- Tham gia
- 1/1/08
- Bài viết
- 2,579
- Được thích
- 3,715
- Donate (Momo)
- Giới tính
- Nam
- Nghề nghiệp
- Quan hệ.. và quan hệ..
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:
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:
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
