Dùng ADO để lấy dữ liệu từ nhiều sheet của 1 file đang đóng?

Chia sẻ bởi:hands

★★★★★

‹ Lấy giữ liệu từ sheet đang đóng... Ghi dữ liệu vào file excel đang... ›

Quảng cáo

Gửi các bạn!

Mình có sưu tầm 1 đoạn code của bạn dhn46 trên diễn đàn GPE để lấy dữ liệu từ 1 sheet của file đang đóng và cho vào 1 sheet của file đang mở, code hoạt động tốt. Tuy nhiên, do nhu cầu công việc nên mình muốn lấy dữ liệu nhiều sheet của 1 file đang đóng cho vào nhiều sheet của file đang mở nhưng mình không biết chỉnh sửa thế nào cho đúng.
(Nếu thực hiện code này nhiều lần thì vẫn cho kết quả như mình mong muốn nhưng như vậy sẽ mất nhiều thời gian cho thao tác chọn file để mở)
Mong các bạn giúp đỡ!

Sub TongHop()
    Dim cnn As Object, lsSQL As String, lrs As Object, Fname
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("ADODB.Connection")
    Set lrs = CreateObject("ADODB.Recordset")
    Application.ScreenUpdating = False
    'Mo hop thoai chon file
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm", 1
        If .Show = -1 Then
            Link = .InitialFileName
        Else
            MsgBox "Ban da khong chon tong hop", vbInformation, "DHN46 - Thong bao"
            Exit Sub
        End If
        'Duyet qua cac file duoc chon
        For Each Fname In .SelectedItems
            'Tao ket noi CSDL
            With cnn
                If Val(Application.Version) < 12 Then
                    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 8.0;HDR=No"";"
                Else
                    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 12.0;HDR=No"";"
                End If
                .Open
            End With
            'Cau lenh truy van
            lsSQL = "SELECT * FROM [THONGKE$A1:AJ65536] WHERE f2 is not Null"
            lrs.Open lsSQL, cnn, 3, 1
            'Copy ket qua vao sheet Tong hop
            Sheet2.Range("A65536").End(3).Offset(1, 0).CopyFromRecordset lrs

cnn.Close
        Next
    End With
    Application.ScreenUpdating = True
    Set lrs = Nothing
    Set cnn = Nothing
End Sub

Thử code này xem sao

Sub TongHop()
    Dim cnn As Object, lsSQL As String, lrs As Object, Fname
    Dim Fso As Object, Link As String, shNameNguon, i As Long
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("ADODB.Connection")
    Set lrs = CreateObject("ADODB.Recordset")
    shNameNguon = Array("THONGKE", "79aHD", "TH79aHD")
    Application.ScreenUpdating = False
    'Mo hop thoai chon file
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm", 1
        If .Show = -1 Then
            Link = .InitialFileName
        Else
            MsgBox "Ban da khong chon tong hop", vbInformation, "DHN46 - Thong bao"
            Exit Sub
        End If
        'Duyet qua cac file duoc chon
        For Each Fname In .SelectedItems
            'Tao ket noi CSDL
            With cnn
                If Val(Application.Version) < 12 Then
                    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 8.0;HDR=No"";"
                Else
                    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 12.0;HDR=No"";"
                End If
                .Open

For i = 0 To UBound(shNameNguon)
            'Cau lenh truy van
                lsSQL = "SELECT * FROM [" & shNameNguon(i) & "$A1:AJ65536] WHERE f2 is not Null"
                lrs.Open lsSQL, cnn, 3, 1
            'Copy ket qua vao sheet Tong hop
                Sheets(shNameNguon(i)).Range("A65536").End(3).Offset(1, 0).CopyFromRecordset lrs
                lrs.Close            
            Next            
            End With
        Next
    End With
    Application.ScreenUpdating = True
    cnn.Close
    Set lrs = Nothing
    Set cnn = Nothing
End Sub

www.giaiphapexcel.com/diendan/threads/d%C3%B9ng-ado-%C4%91%E1%BB%83-l%E1%BA%A5y-d%E1%BB%AF-li%E1%BB%87u-t%E1%BB%AB-nhi%E1%BB%81u-sheet-c%E1%BB%A7a-1-file-%C4%91ang-%C4%91%C3%B3ng.94032/