Lấy tên sheet từ file đang đóng bằng ADO

tuhocvba · 27/2/23

Chạy thủ tục cuối cùng trong code. Chú ý thiết định thư viện.

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

Các dòng code khai báo sớm mình muốn thay bằng kiểu như này:

Mã:

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

Nhưng hiện tại đang bị lỗi. @NhanSu xem giúp mình nhé.

NhanSu · 27/2/23

@tuhocvba

Mã:

Option Explicit

Private cn_  As Object 

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_ = CreateObject("ADODB.Connection") 
    End If

    If cn_.State <> 1 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 <> 0 Then
            cn_.Close
        End If

        Set cn_ = Nothing
    End If

End Sub
Public Function getSheetNames(ByRef sSheetNames() As String) As Long

    Dim rs          As Object
    Dim fld         As Object
    Dim lCount      As Long
    Dim sTableName  As String
    Dim i&

    getSheetNames = 0

On Error GoTo ERR_GET_SHEET_NAMES

    Set rs = cn_.OpenSchema(20)

    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 <> 0 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 = ThisWorkbook.FullName

    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

tuhocvba · 27/2/23

Chạy bị lỗi mà @NhanSu

NhanSu · 27/2/23

Máy mình sau khi sửa chạy bình thường, không hiểu sao.

tuhocvba · 27/2/23

File của mình bị sao đó. Chuyển code sang file khác là OK. Cảm ơn @NhanSu

Lấy tên sheet từ file đang đóng bằng ADO

tuhocvba

Administrator

NhanSu

SMod

tuhocvba

Administrator

NhanSu

SMod

tuhocvba

Administrator