Private Cnn As New ADODB.Connection
Private Rst As New ADODB.Recordset
Private AccPath As String, TableName As String
Private SQL As String, MyString As String
Rem ==========
Private Function Connection(ByVal AccPath As String) As ADODB.Connection
Rem Tools/References - VBAProject/Microsoft ActiveX Data Objects 6.1 Library
Set Cnn = New ADODB.Connection
Cnn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=") _
& AccPath & ";Persist Security Info=False"
Set Connection = Cnn
End Function
Rem ==========
Private Sub CopyTableName(ByVal AccPath As String, ByVal TableName As String, ByVal Target As Range)
Target.CopyFromRecordset Connection(AccPath).Execute(TableName)
End Sub
Rem ==========
Private Sub InsertQuery(ByVal Cnn As ADODB.Connection, ByVal TableName$, sArr(), _
Optional ByVal ColFilter = "", Optional ByVal DelTableName As Boolean = False)
Dim i As Long, j As Long, Qry As String
Set Rst = New ADODB.Recordset
If ColFilter = "" Then ColFilter = 1
If ColFilter = 0 Or ColFilter > UBound(sArr, 2) Then Exit Sub
' On Error GoTo Errorhandler ''Xu Ly loi khi mang Lon Hon tableName Or vv...
Rem Set Cnn = Connection(AccPath) ''Bo Tham So Cnn ap dung cho Chay Nhieu Sub truyen 1 Lan Tham So Cnn
If DelTableName Then Cnn.Execute ("DELETE * FROM ") & TableName
For i = 1 To UBound(sArr, 1)
Qry = " INSERT INTO " & TableName & " VALUES(" & i
If sArr(i, ColFilter) <> "" Then
For j = 1 To UBound(sArr, 2)
Qry = Qry & ", " & GetValue(sArr(i, j))
Next
Qry = Qry & " )"
Rst.Open Qry, Cnn, adOpenStatic, adLockOptimistic
End If
Next
Cnn.Close: Set Cnn = Nothing
' Exit Sub
'Errorhandler:
' MsgBox "Error #: " & Err.Number _
' & vbCrLf & Err.Description
' Rem Range("B1").Value = Err.Number & Err.Description ''Search Google For Err
Err.Clear
End Sub
Rem ==========
Public Sub Main_ADO()
Dim Arr()
TableName = "NhapXuatTon"
AccPath = ThisWorkbook.Path & "\QLBHPN.accdb"
Set Cnn = Connection(AccPath)
Arr = Range("B4:I100").Value
''Call InsertQuery(Cnn, TableName, Arr(), 1, False)
Call InsertQuery(Cnn, TableName, Arr(), 1, True)
Sheet4.Range("K4:S1000").ClearContents
Call CopyTableName(AccPath, TableName, Sheet4.Range("K4"))
End Sub
[code]
