Option Explicit
Public Cnn As Object, Rst As Object
Rem ==========
Public Function MyRecordset() As Object
Set MyRecordset = CreateObject("ADODB.Recordset")
End Function
Rem ==========
Public Function MyConnection() As Object
Set MyConnection = CreateObject("ADODB.Connection")
End Function
Rem ==========
Private Function Connection(ByVal FilePath As String)
Set Cnn = MyConnection()
Cnn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=") & FilePath
Set Connection = Cnn
End Function
Rem ==========
Private Function GetFilePath(ByVal AccPath As String)
GetFilePath = ("Driver={Microsoft Access Driver (*.mdb, *.accdb)};Dbq=" & AccPath & ";Uid=Admin;Pwd=;")
End Function
Rem ==========
Public Sub GetDataBase(ByVal AccessPath As String, ByVal TableName As String, ByVal Target As Range)
Set Cnn = MyConnection()
Cnn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=") & AccessPath
Set Rst = Cnn.Execute("select * from [" & TableName & "]")
Target.CopyFromRecordset Rst
Set Cnn = Nothing: Set Rst = Nothing
End Sub
Rem ==========
Public Function TransArr(ByVal sArr As Variant) As Variant
Dim TmpArr As Variant, x As Long, y As Long
ReDim TmpArr(UBound(sArr, 2), UBound(sArr, 1))
For x = 0 To UBound(sArr, 2)
For y = 0 To UBound(sArr, 1)
TmpArr(x, y) = sArr(y, x)
Next y
Next x
TransArr = TmpArr
End Function
Rem ==========
Private Sub GetDataArr(ByVal AccPath As String, ByVal TableName As String, Res())
On Error GoTo Thoat ''xu ly loi khi du lieu Empty
Set Cnn = MyConnection()
Cnn.ConnectionString = GetFilePath(AccPath)
Cnn.Open
Set Rst = Cnn.Execute("select * from " & "[" & TableName & "]")
Res = TransArr(Rst.GetRows())
Thoat: Set Cnn = Nothing: Set Rst = Nothing
End Sub
Rem ==========
Private Sub DeleteTableName(ByVal FilePath As String, ByVal TableName As String)
Set Cnn = Connection(FilePath)
Set Rst = Cnn.Execute("DELETE * FROM " & TableName)
Set Cnn = Nothing: Set Rst = Nothing
End Sub
Rem ==========
Private Function GetConnectionData(ByVal aPath As String) As Long
On Error GoTo ErrorHandle
Set Cnn = MyConnection()
With Cnn
.Mode = 3
.ConnectionTimeout = 30
.CursorLocation = 3
.ConnectionString = GetFilePath(aPath)
.Open
End With
GetConnectionData = 1
Cnn.Close
ErrorHandle: Err.Clear
End Function
Rem ==========
Private Sub InsertDataBase(ByVal AccPath$, ByVal TableName$, Res())
Dim i As Long, ColFieldNames(), ExArr()
If (GetConnectionData(AccPath)) Then
Cnn.Open
ColFieldNames = Array(1, 2, 3, 4, 5, 6) ''Ban co the thay doi [Field] Tuy theo so truong cua ban
Set Rst = MyRecordset()
Rst.CursorLocation = 3 ''adUseClient
Rst.Open TableName, Cnn, 3, 4 ''adOpenStatic, adLockBatchOptimistic
For i = 1 To UBound(Res, 1) ''Tuy cho thay doi du lieu tren Excel cho phu Hop voi ColFieldNames
If Len(Res(i, 2)) > 0 Then
ExArr = Array(Res(i, 1), Res(i, 2), _
Res(i, 3), Res(i, 4), _
Res(i, 5), Res(i, 6))
Rst.AddNew ColFieldNames, ExArr()
End If
Next i
Rst.UpdateBatch
Beep 'MsgBox "Ban da xuat du lieu thanh cong.", 64, "Thông Báo"
Else
MsgBox "Khong the ket noi voi CSDL...", 48, "Thông Báo"
End If
Set Rst = Nothing: Set Cnn = Nothing
End Sub
Rem ==========
Public Sub ExcelToAccess()
Dim Arr(), Path As String, sTableName As String
sTableName = ("DataNhap")
Path = ThisWorkbook.Path & "\QLBHPN.accdb"
Arr = Sheets("PhieuXuat").Range("B6:G86").Value
Call InsertDataBase(Path, sTableName, Arr())
End Sub
Rem ========== Con Ham nay lay len Cot % dung theo luc ghi Vao ????!!!!
Public Sub AccessToExcel()
Dim Path As String, Table As String
Dim Sht As Worksheet
Set Sht = ThisWorkbook.Worksheets("Data")
Table = ("DataNhap")
Call DeleteData
Path = ThisWorkbook.Path & "\QLBHPN.accdb"
Call GetDataBase(Path, Table, Sht.Range("A2"))
End Sub
Rem ========== tai sao dung code nay lay du lieu Len Cot % lai La $0.8 ???!!!!
Public Sub AccessToExcel_TransArr()
Dim FilePath$, sTableName$, Arr()
sTableName = ("DataNhap")
FilePath = ThisWorkbook.Path & "\QLBHPN.accdb"
Call DeleteData
Call GetDataArr(FilePath, sTableName, Arr())
Rem Se loi dong sau khi du lieu Empty
Sheet2.Range("A2").Resize(UBound(Arr) + 1, UBound(Arr, 2) + 1) = Arr
End Sub
Rem ==========
Public Sub Delete_TableName()
Dim sPath As String, Table As String
Table = "DataNhap" ''Ten Bang du lieu trong Access
sPath = ThisWorkbook.Path & "\QLBHPN.accdb"
Call DeleteTableName(sPath, Table)
End Sub
Rem ==========
Public Sub DeleteData()
Sheet2.Cells.Clear
End Sub
