VBAG02 - Ứng dụng Mảng, SQL và các Công cụ Nâng cao khác trong Excel và VBA

Option Explicit
Function QuerySQL(SQLQuery As String, spart As String, Optional Hr As Boolean = False, Optional Pasword As String = "123")
   Dim Cnn As Object, lrs As Object, SQLQuyery As String, Path As String, Ketnoi As Boolean
   Set Cnn = CreateObject("ADODB.Connection")
   Set lrs = CreateObject("ADODB.Recordset")
   If (CheckPart(spart) = "EXCEL") Then
       If Val(Application.Version) > 12 Then
           Cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & spart & ";Extended Properties=""Excel 12.0;HDR=YES;IMEX=0"";"
       Else
           Cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & spart & ";Extended Properties=""Excel 8.0;HDR=YES;IMEX=0"";"
       End If
   ElseIf (CheckPart(spart) = "ACCESS") Then
       If Val(Application.Version) > 12 Then
           Cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & spart & ";Persist Security Info=False; Jet OLEDB:Database Password=" & Pasword & ";"
       Else
           Cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & spart & ";Persist Security Info=False; Jet OLEDB:Database Password=" & Pasword & ";"
       End If
   Else
           Cnn.ConnectionString = spart
   End If
   Ketnoi = False
   On Error GoTo ThoatKN
   Cnn.Open
   Ketnoi = True
   GoTo ThoatKN
ThoatKN:
   If (Ketnoi) Then
   On Error GoTo ThoatLrs
     lrs.Open SQLQuery, Cnn
     Dim arr As Variant
     arr = lrs.Getrows
     GoTo ThoatLrs
ThoatLrs:
     If IsArray(arr) Then
         Dim Row As Long, Col As Long, i As Long, j As Long, kq As Variant, rs As Integer
         If Hr = True Then
             rs = 1
         Else
             rs = 0
         End If
         Row = UBound(arr, 2) + rs
         Col = UBound(arr, 1)
         ReDim kq(Row + 1 + rs, Col + rs)
         For i = 0 To Row
             For j = 0 To Col
              If (i = 0 And Hr = True) Then
                 kq(0, j) = lrs.Fields(j).Name
              Else
                  kq(i, j) = arr(j, i - rs)
              End If
             Next j
         Next i
       QuerySQL = kq
       lrs.Close: Cnn.Close
       Erase arr: Erase kq
   Else
       QuerySQL = "Không có d" & ChrW(7919) & " li" & ChrW(7879) & "u"
   End If
 Else
       QuerySQL = "Không có k" & ChrW(7871) & "t n" & ChrW(7889) & "i"
 End If
End Function
Function QuerySQLExecute(SQLQuery As String, spart As String, Optional loi As Boolean = False, Optional Pasword As String = "123") As Boolean
   Dim Cnn As Object, cmd As Object, SQLQuyery As String, Path As String, Ketnoi As Boolean, Thongbao As String
   Set Cnn = CreateObject("ADODB.Connection")
   Set cmd = CreateObject("ADODB.Command")
   If (CheckPart(spart) = "EXCEL") Then
       If Val(Application.Version) > 12 Then
           Cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & spart & ";Extended Properties=""Excel 12.0;HDR=YES;IMEX=0"";"
Else
           Cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & spart & ";Extended Properties=""Excel 8.0;HDR=YES;IMEX=0"";"
       End If
   ElseIf (CheckPart(spart) = "ACCESS") Then
       If Val(Application.Version) > 12 Then
           Cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & spart & ";Persist Security Info=False; Jet OLEDB:Database Password=" & Pasword & ";"
       Else
           Cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & spart & ";Persist Security Info=False; Jet OLEDB:Database Password=" & Pasword & ";"
       End If
   Else
           Cnn.ConnectionString = spart
   End If
   Ketnoi = False
   On Error GoTo ThoatKN
   Cnn.Open
   Ketnoi = True
   GoTo ThoatKN
ThoatKN:
   If (Ketnoi) Then
       On Error GoTo Err
           With cmd
               .ActiveConnection = Cnn
               .CommandText = SQLQuery
               .Execute
           End With
       Thongbao = "Th" & ChrW(7921) & "c hi" & ChrW(7879) & "n th" & ChrW(224) & "nh c" & ChrW(244) & "ng"
'        If Loi = True Then MsgBoxUni Thongbao, vbInformation, "Thông báo"
       QuerySQLExecute = True
       Exit Function
       GoTo Err
   End If
Err:
   If loi = True Then
       If (InStr(Err.Description, "The duplicate key value is")) Then
           Thongbao = "Trùng khoá chính"
           MsgBox Thongbao, vbExclamation, "Thông Báo Error"
       ElseIf (Err.Description = "The changes you requested to the table were not successful because they would create duplicate values in the index, primary key, or relationship. Change the data in the field or fields that contain duplicate data, remove the index, or redefine the index to permit duplicate entries and try again.") Then
           Thongbao = "Tr" & ChrW(249) & "ng kho" & ChrW(225) & " ch" & ChrW(237) & "nh kh" & ChrW(244) & "ng th" & ChrW(7875) & " th" & ChrW(234) & "m"
           MsgBox Thongbao
        ElseIf (Err.Description = "Number of query values and destination fields are not the same.") Then
              Thongbao = "S" & ChrW(7889) & " l" & ChrW(432) & ChrW(7907) & "ng tr" & ChrW(432) & ChrW(7901) & "ng truy v" & ChrW(7845) & "n v" & ChrW(224) & " tr" & ChrW(432) & ChrW(7901) & "ng " & ChrW(273) & ChrW(237) & "ch kh" & ChrW(244) & "ng b" & ChrW(7857) & "ng nhau"
               MsgBox Thongbao, vbExclamation, "Thông Báo Error"
        ElseIf (InStr(Err.Description, "The duplicate key value is")) Then
              Thongbao = "Tr" & ChrW(249) & "ng kho" & ChrW(225) & " ch" & ChrW(237) & "nh kh" & ChrW(244) & "ng th" & ChrW(7875) & " th" & ChrW(234) & "m"
              MsgBox Thongbao, vbExclamation, "Thông Báo Error"
       Else
           MsgBox Err.Description
       End If
   End If
   QuerySQLExecute = False
End Function
Function CheckPart(s As String) As String
   Dim kq As String, GetName As String
   GetName = Split(s, ".")(UBound(Split(s, ".")))

Option Explicit
Function QuerySQL(SQLQuery As String, spart As String, Optional Hr As Boolean = False, Optional Pasword As String = "123")
   Dim Cnn As Object, lrs As Object, SQLQuyery As String, Path As String, Ketnoi As Boolean
   Set Cnn = CreateObject("ADODB.Connection")
   Set lrs = CreateObject("ADODB.Recordset")
   If (CheckPart(spart) = "EXCEL") Then
       If Val(Application.Version) > 12 Then
           Cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & spart & ";Extended Properties=""Excel 12.0;HDR=YES;IMEX=0"";"
       Else
           Cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & spart & ";Extended Properties=""Excel 8.0;HDR=YES;IMEX=0"";"
       End If
   ElseIf (CheckPart(spart) = "ACCESS") Then
       If Val(Application.Version) > 12 Then
           Cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & spart & ";Persist Security Info=False; Jet OLEDB:Database Password=" & Pasword & ";"
       Else
           Cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & spart & ";Persist Security Info=False; Jet OLEDB:Database Password=" & Pasword & ";"
       End If
   Else
           Cnn.ConnectionString = spart
   End If
   Ketnoi = False
   On Error GoTo ThoatKN
   Cnn.Open
   Ketnoi = True
   GoTo ThoatKN
ThoatKN:
   If (Ketnoi) Then
   On Error GoTo ThoatLrs
     lrs.Open SQLQuery, Cnn
     Dim arr As Variant
     arr = lrs.Getrows
     GoTo ThoatLrs
ThoatLrs:
     If IsArray(arr) Then
         Dim Row As Long, Col As Long, i As Long, j As Long, kq As Variant, rs As Integer
         If Hr = True Then
             rs = 1
         Else
             rs = 0
         End If
         Row = UBound(arr, 2) + rs
         Col = UBound(arr, 1)
         ReDim kq(Row + 1 + rs, Col + rs)
         For i = 0 To Row
             For j = 0 To Col
              If (i = 0 And Hr = True) Then
                 kq(0, j) = lrs.Fields(j).Name
              Else
                  kq(i, j) = arr(j, i - rs)
              End If
             Next j
         Next i
       QuerySQL = kq
       lrs.Close: Cnn.Close
       Erase arr: Erase kq
   Else
       QuerySQL = "Không có d" & ChrW(7919) & " li" & ChrW(7879) & "u"
   End If
 Else
       QuerySQL = "Không có k" & ChrW(7871) & "t n" & ChrW(7889) & "i"
 End If
End Function
Function QuerySQLExecute(SQLQuery As String, spart As String, Optional loi As Boolean = False, Optional Pasword As String = "123") As Boolean
   Dim Cnn As Object, cmd As Object, SQLQuyery As String, Path As String, Ketnoi As Boolean, Thongbao As String
   Set Cnn = CreateObject("ADODB.Connection")
   Set cmd = CreateObject("ADODB.Command")
   If (CheckPart(spart) = "EXCEL") Then
       If Val(Application.Version) > 12 Then
           Cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & spart & ";Extended Properties=""Excel 12.0;HDR=YES;IMEX=0"";"
Else
           Cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & spart & ";Extended Properties=""Excel 8.0;HDR=YES;IMEX=0"";"
       End If
   ElseIf (CheckPart(spart) = "ACCESS") Then
       If Val(Application.Version) > 12 Then
           Cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & spart & ";Persist Security Info=False; Jet OLEDB:Database Password=" & Pasword & ";"
       Else
           Cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & spart & ";Persist Security Info=False; Jet OLEDB:Database Password=" & Pasword & ";"
       End If
   Else
           Cnn.ConnectionString = spart
   End If
   Ketnoi = False
   On Error GoTo ThoatKN
   Cnn.Open
   Ketnoi = True
   GoTo ThoatKN
ThoatKN:
   If (Ketnoi) Then
       On Error GoTo Err
           With cmd
               .ActiveConnection = Cnn
               .CommandText = SQLQuery
               .Execute
           End With
       Thongbao = "Th" & ChrW(7921) & "c hi" & ChrW(7879) & "n th" & ChrW(224) & "nh c" & ChrW(244) & "ng"
'        If Loi = True Then MsgBoxUni Thongbao, vbInformation, "Thông báo"
       QuerySQLExecute = True
       Exit Function
       GoTo Err
   End If
Err:
   If loi = True Then
       If (InStr(Err.Description, "The duplicate key value is")) Then
           Thongbao = "Trùng khoá chính"
           MsgBox Thongbao, vbExclamation, "Thông Báo Error"
       ElseIf (Err.Description = "The changes you requested to the table were not successful because they would create duplicate values in the index, primary key, or relationship. Change the data in the field or fields that contain duplicate data, remove the index, or redefine the index to permit duplicate entries and try again.") Then
           Thongbao = "Tr" & ChrW(249) & "ng kho" & ChrW(225) & " ch" & ChrW(237) & "nh kh" & ChrW(244) & "ng th" & ChrW(7875) & " th" & ChrW(234) & "m"
           MsgBox Thongbao
        ElseIf (Err.Description = "Number of query values and destination fields are not the same.") Then
              Thongbao = "S" & ChrW(7889) & " l" & ChrW(432) & ChrW(7907) & "ng tr" & ChrW(432) & ChrW(7901) & "ng truy v" & ChrW(7845) & "n v" & ChrW(224) & " tr" & ChrW(432) & ChrW(7901) & "ng " & ChrW(273) & ChrW(237) & "ch kh" & ChrW(244) & "ng b" & ChrW(7857) & "ng nhau"
               MsgBox Thongbao, vbExclamation, "Thông Báo Error"
        ElseIf (InStr(Err.Description, "The duplicate key value is")) Then
              Thongbao = "Tr" & ChrW(249) & "ng kho" & ChrW(225) & " ch" & ChrW(237) & "nh kh" & ChrW(244) & "ng th" & ChrW(7875) & " th" & ChrW(234) & "m"
              MsgBox Thongbao, vbExclamation, "Thông Báo Error"
       Else
           MsgBox Err.Description
       End If
   End If
   QuerySQLExecute = False
End Function
Function CheckPart(s As String) As String
   Dim kq As String, GetName As String
   GetName = Split(s, ".")(UBound(Split(s, ".")))

Option Explicit
Function QuerySQL(SQLQuery As String, spart As String, Optional Hr As Boolean = False, Optional Pasword As String = "123")
   Dim Cnn As Object, lrs As Object, SQLQuyery As String, Path As String, Ketnoi As Boolean
   Set Cnn = CreateObject("ADODB.Connection")
   Set lrs = CreateObject("ADODB.Recordset")
   If (CheckPart(spart) = "EXCEL") Then
       If Val(Application.Version) > 12 Then
           Cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & spart & ";Extended Properties=""Excel 12.0;HDR=YES;IMEX=0"";"
       Else
           Cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & spart & ";Extended Properties=""Excel 8.0;HDR=YES;IMEX=0"";"
       End If
   ElseIf (CheckPart(spart) = "ACCESS") Then
       If Val(Application.Version) > 12 Then
           Cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & spart & ";Persist Security Info=False; Jet OLEDB:Database Password=" & Pasword & ";"
       Else
           Cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & spart & ";Persist Security Info=False; Jet OLEDB:Database Password=" & Pasword & ";"
       End If
   Else
           Cnn.ConnectionString = spart
   End If
   Ketnoi = False
   On Error GoTo ThoatKN
   Cnn.Open
   Ketnoi = True
   GoTo ThoatKN
ThoatKN:
   If (Ketnoi) Then
   On Error GoTo ThoatLrs
     lrs.Open SQLQuery, Cnn
     Dim arr As Variant
     arr = lrs.Getrows
     GoTo ThoatLrs
ThoatLrs:
     If IsArray(arr) Then
         Dim Row As Long, Col As Long, i As Long, j As Long, kq As Variant, rs As Integer
         If Hr = True Then
             rs = 1
         Else
             rs = 0
         End If
         Row = UBound(arr, 2) + rs
         Col = UBound(arr, 1)
         ReDim kq(Row + 1 + rs, Col + rs)
         For i = 0 To Row
             For j = 0 To Col
              If (i = 0 And Hr = True) Then
                 kq(0, j) = lrs.Fields(j).Name
              Else
                  kq(i, j) = arr(j, i - rs)
              End If
             Next j
         Next i
       QuerySQL = kq
       lrs.Close: Cnn.Close
       Erase arr: Erase kq
   Else
       QuerySQL = "Không có d" & ChrW(7919) & " li" & ChrW(7879) & "u"
   End If
 Else
       QuerySQL = "Không có k" & ChrW(7871) & "t n" & ChrW(7889) & "i"
 End If
End Function
Function QuerySQLExecute(SQLQuery As String, spart As String, Optional loi As Boolean = False, Optional Pasword As String = "123") As Boolean
   Dim Cnn As Object, cmd As Object, SQLQuyery As String, Path As String, Ketnoi As Boolean, Thongbao As String
   Set Cnn = CreateObject("ADODB.Connection")
   Set cmd = CreateObject("ADODB.Command")
   If (CheckPart(spart) = "EXCEL") Then
       If Val(Application.Version) > 12 Then
           Cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & spart & ";Extended Properties=""Excel 12.0;HDR=YES;IMEX=0"";"
Else
           Cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & spart & ";Extended Properties=""Excel 8.0;HDR=YES;IMEX=0"";"
       End If
   ElseIf (CheckPart(spart) = "ACCESS") Then
       If Val(Application.Version) > 12 Then
           Cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & spart & ";Persist Security Info=False; Jet OLEDB:Database Password=" & Pasword & ";"
       Else
           Cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & spart & ";Persist Security Info=False; Jet OLEDB:Database Password=" & Pasword & ";"
       End If
   Else
           Cnn.ConnectionString = spart
   End If
   Ketnoi = False
   On Error GoTo ThoatKN
   Cnn.Open
   Ketnoi = True
   GoTo ThoatKN
ThoatKN:
   If (Ketnoi) Then
       On Error GoTo Err
           With cmd
               .ActiveConnection = Cnn
               .CommandText = SQLQuery
               .Execute
           End With
       Thongbao = "Th" & ChrW(7921) & "c hi" & ChrW(7879) & "n th" & ChrW(224) & "nh c" & ChrW(244) & "ng"
'        If Loi = True Then MsgBoxUni Thongbao, vbInformation, "Thông báo"
       QuerySQLExecute = True
       Exit Function
       GoTo Err
   End If
Err:
   If loi = True Then
       If (InStr(Err.Description, "The duplicate key value is")) Then
           Thongbao = "Trùng khoá chính"
           MsgBox Thongbao, vbExclamation, "Thông Báo Error"
       ElseIf (Err.Description = "The changes you requested to the table were not successful because they would create duplicate values in the index, primary key, or relationship. Change the data in the field or fields that contain duplicate data, remove the index, or redefine the index to permit duplicate entries and try again.") Then
           Thongbao = "Tr" & ChrW(249) & "ng kho" & ChrW(225) & " ch" & ChrW(237) & "nh kh" & ChrW(244) & "ng th" & ChrW(7875) & " th" & ChrW(234) & "m"
           MsgBox Thongbao
        ElseIf (Err.Description = "Number of query values and destination fields are not the same.") Then
              Thongbao = "S" & ChrW(7889) & " l" & ChrW(432) & ChrW(7907) & "ng tr" & ChrW(432) & ChrW(7901) & "ng truy v" & ChrW(7845) & "n v" & ChrW(224) & " tr" & ChrW(432) & ChrW(7901) & "ng " & ChrW(273) & ChrW(237) & "ch kh" & ChrW(244) & "ng b" & ChrW(7857) & "ng nhau"
               MsgBox Thongbao, vbExclamation, "Thông Báo Error"
        ElseIf (InStr(Err.Description, "The duplicate key value is")) Then
              Thongbao = "Tr" & ChrW(249) & "ng kho" & ChrW(225) & " ch" & ChrW(237) & "nh kh" & ChrW(244) & "ng th" & ChrW(7875) & " th" & ChrW(234) & "m"
              MsgBox Thongbao, vbExclamation, "Thông Báo Error"
       Else
           MsgBox Err.Description
       End If
   End If
   QuerySQLExecute = False
End Function
Function CheckPart(s As String) As String
   Dim kq As String, GetName As String
   GetName = Split(s, ".")(UBound(Split(s, ".")))
GetName = LCase(GetName)
   If (GetName = "xls" Or GetName = "xlsx" Or GetName = "xlsm" Or GetName = "xlsb") Then
       kq = "EXCEL"
   ElseIf (GetName = "mdb" Or GetName = "accdb") Then
       kq = "ACCESS"
   Else
       kq = "SQLSEVER"
   End If
   CheckPart = kq
End Function

 nhờ thầy xem dùM. EM THÊM MẬT KHẨU VÀO THÌ K LẤY DƯỢC DỮ LIỆU CÒN BỎ MẬT KHẨU LẠI LẤY DƯỢC DỮ LIỆU. THẦY CÓ THỂ LÀM VI DEO HƯỚNG DẪN GIÚP EM Ạ

thầy có thể hướng dẫn bằng video chi tiết hơn không ạ

• các tạo và bỏ mật khẩu khoá file access
• code lấy dữ liệu từ file access đang khoá truyền vào userform