Chạy thủ tục cuối cùng trong code. Chú ý thiết định thư viện.
Các dòng code khai báo sớm mình muốn thay bằng kiểu như này:
Nhưng hiện tại đang bị lỗi. @NhanSu xem giúp mình nhé.
Mã:
Private cn_ As ADODB.Connection
Public Function connectDB(ByVal sDBPath As String, Optional ByVal bExistsHeaderRow As Boolean = True) As Long
Dim sExistsHeaderRow As String
Dim sConnectionString As String
If bExistsHeaderRow = True Then
sExistsHeaderRow = "Yes"
Else
sExistsHeaderRow = "No"
End If
' HDR=Yes===>Lay dong dau tien lam tieu de
' IMEX = 1: Read only
sConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & sDBPath & ";" & _
"Extended Properties=""Excel 12.0 Xml;" & _
"HDR=" & sExistsHeaderRow & ";" & _
"IMEX=1;"""
On Error GoTo ERR_CONNECT_DB
If cn_ Is Nothing Then
Set cn_ = New ADODB.Connection
End If
If cn_.State <> adStateOpen Then
cn_.Open sConnectionString
End If
connectDB = 0
Exit Function
ERR_CONNECT_DB:
Debug.Print Err.Number & ":" & Err.Description
connectDB = Err.Number
End Function
Public Sub disconnectDB()
If Not cn_ Is Nothing Then
If cn_.State <> adStateClosed Then
cn_.Close
End If
Set cn_ = Nothing
End If
End Sub
Public Function getSheetNames(ByRef sSheetNames() As String) As Long
Dim rs As ADODB.Recordset
Dim fld As ADODB.Field
Dim lCount As Long
Dim sTableName As String
Dim i&
getSheetNames = 0
On Error GoTo ERR_GET_SHEET_NAMES
Set rs = cn_.OpenSchema(adSchemaTables)
lCount = 0
ReDim sSheetNames(lCount)
Do Until (rs.EOF)
sTableName = rs.Fields("TABLE_NAME").Value
If InStr(1, sTableName, "P8_Criteria A" & "$", vbTextCompare) > 0 Then
MsgBox sTableName
End If
If Right(sTableName, 1) = "$" Then
'Ten sheet duoc xacs dinh la khong co $
'Khi de auto filter, hoac chi dinh pham vi in, thi ten xuat ra co the co them _xlnm#, nen can phot lo chung
'Bo ky tu $ o cuoi di
sTableName = Left(sTableName, Len(sTableName) - 1)
ReDim Preserve sSheetNames(lCount)
sSheetNames(lCount) = sTableName
lCount = lCount + 1
End If
rs.MoveNext
Loop
ERR_GET_SHEET_NAMES:
If Err.Number <> 0 Then
getSheetNames = -Err.Number
Else
getSheetNames = lCount
End If
If Not rs Is Nothing Then
If rs.State <> adStateClosed Then
rs.Close
End If
Set rs = Nothing
End If
End Function
'Nguon tham khao: https://z1000s.hatenablog.com/entry/2019/04/03/122123
'Thiet dinh thu vien Microsoft ActiveX Data Objects 6.1 Library
'Thiet dinh thu vien Microsoft ActiveX Data Objects Recordset 6.0 Library
Public Sub getTargetSheetNameADO()
Dim sTargetPath As String
Dim sSheetNames() As String
Dim i As Long
Dim sgStart As Single
Dim sgStop As Single
sgStart = Timer
'Lay ten sheet name cua file duoi day:
sTargetPath = "C:\VBA\tuhocvba.xlsx"
Call connectDB(sTargetPath, False)
Call getSheetNames(sSheetNames)
For i = 0 To UBound(sSheetNames)
Debug.Print sSheetNames(i)
Next i
Debug.Print ""
Call disconnectDB
sgStop = Timer
Debug.Print "ADO : " & Format$(sgStop - sgStart, "0.00 sec.")
End Sub
Mã:
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")