Tổng hợp dữ liệu nhều file có cấu trúc giống nhau bằng truy vấn (ADODB)

S

shnhatha

Yêu THVBA
Tôi có đoạn code tổng hợp dữ liệu từ sheet đóng vào sheet tổng hợp.Khi chạy code, nếu chỉ lấy 1 file thì không vấn đề gì.Nếu chọn nhiều file sẽ báo lỗi..!
Nhờ anh chị em diễn đàn trợ giúp chỉnh sửa.!

Bạn cần đăng nhập để thấy link



Mã: 
Sub THDL_CA()
    Dim cnn As Object, lsSQL As String, lrs As Object, Fname
    Dim Fso As Object, Link As String, Nguon, Dich, i As Long
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("ADODB.Connection")
    Set lrs = CreateObject("ADODB.Recordset")
    Nguon = Array("NGAY_1", "NGAY_2")
    Dich = Array("SH_1", "SH_2")
    
    Application.ScreenUpdating = False
    
    

  Selection.Parent.AutoFilterMode = False
 
    
 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, "Thong Bao"
            Exit Sub
        End If
    
        For Each Fname In .SelectedItems
      
            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(Nguon)
      
                lsSQL = "SELECT * FROM [" & Nguon(i) & "$A8:V20000]"
               lrs.Open lsSQL, cnn, 3, 1
              Sheets(Dich(i)).Range("A6:AK6").AutoFilter
                Sheets(Dich(i)).Range("A6:V15000").ClearContents
                Sheets(Dich(i)).Range("A15000").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
 
C

CRV

SMod
Thành viên BQT
Tôi đã di chuyển phần mở và đóng kết nối vào vòng lặp For Each để mỗi lần lặp lại sẽ mở một kết nối mới và đóng kết nối cũ.
Điều này giúp tránh lỗi xảy ra khi đang sử dụng một kết nối đang mở trong khi cố gắng mở một kết nối khác.
Bạn kiểm tra lại ... :
Mã: 
Option Explicit

Sub THDL_CA()

    Dim cnn As Object, lsSQL As String, lrs As Object, Fname
    Dim Fso As Object, Link As String, Nguon, Dich, i As Long
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("ADODB.Connection")
    Set lrs = CreateObject("ADODB.Recordset")
    Nguon = Array("NGAY_1", "NGAY_2")
    Dich = Array("SH_1", "SH_2")
   
    Application.ScreenUpdating = False
   
    Selection.Parent.AutoFilterMode = False
   
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm", 1
        If .Show = -1 Then
            For Each Fname In .SelectedItems
                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
               
                For i = 0 To UBound(Nguon)
                    lsSQL = "SELECT * FROM [" & Nguon(i) & "$A8:V20000]"
                    lrs.Open lsSQL, cnn, 3, 1
                    Sheets(Dich(i)).Range("A6:AK6").AutoFilter
                    Sheets(Dich(i)).Range("A6:V15000").ClearContents
                    Sheets(Dich(i)).Range("A15000").End(3).Offset(1, 0).CopyFromRecordset lrs
                    lrs.Close
                Next
                cnn.Close
            Next
        Else
            MsgBox "Ban da khong chon tong hop", vbInformation, "Thong Bao"
        End If
    End With
   
    Application.ScreenUpdating = True
    Set lrs = Nothing
    Set cnn = Nothing
End Sub
 
S

shnhatha

Yêu THVBA
CRV nói:
Tôi đã di chuyển phần mở và đóng kết nối vào vòng lặp For Each để mỗi lần lặp lại sẽ mở một kết nối mới và đóng kết nối cũ.
Điều này giúp tránh lỗi xảy ra khi đang sử dụng một kết nối đang mở trong khi cố gắng mở một kết nối khác.
Bạn kiểm tra lại ... :
Mã: 
Option Explicit

Sub THDL_CA()

    Dim cnn As Object, lsSQL As String, lrs As Object, Fname
    Dim Fso As Object, Link As String, Nguon, Dich, i As Long
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("ADODB.Connection")
    Set lrs = CreateObject("ADODB.Recordset")
    Nguon = Array("NGAY_1", "NGAY_2")
    Dich = Array("SH_1", "SH_2")
 
    Application.ScreenUpdating = False
 
    Selection.Parent.AutoFilterMode = False
 
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm", 1
        If .Show = -1 Then
            For Each Fname In .SelectedItems
                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
             
                For i = 0 To UBound(Nguon)
                    lsSQL = "SELECT * FROM [" & Nguon(i) & "$A8:V20000]"
                    lrs.Open lsSQL, cnn, 3, 1
                    Sheets(Dich(i)).Range("A6:AK6").AutoFilter
                    Sheets(Dich(i)).Range("A6:V15000").ClearContents
                    Sheets(Dich(i)).Range("A15000").End(3).Offset(1, 0).CopyFromRecordset lrs
                    lrs.Close
                Next
                cnn.Close
            Next
        Else
            MsgBox "Ban da khong chon tong hop", vbInformation, "Thong Bao"
        End If
    End With
 
    Application.ScreenUpdating = True
    Set lrs = Nothing
    Set cnn = Nothing
End Sub
Nhấn để mở rộng...
Cảm ơn bạn..đúng là mình bị mắc ở đoạn vòng Lặp đó..khi mình cố chạy từng bước đều báo lỗi khi lấy xong dữ liệu file đầu,không thể tiếp mở file tiếp theo .giờ mình đã hiểu..Mỗi vấn đề được giải đáp là một bài học bổ ích.Cảm ơn bạn cảm ơn diễn đàn!
 
  • Love
Reactions: CRV
Bạn phải đăng nhập hoặc đăng ký để bình luận.
Top