shnhatha221108
Thành viên chính thức 


			
		- Tham gia
 - 2/10/18
 
- Bài viết
 - 73
 
- Được thích
 - 13
 
Em muốn tổng hợp dữ liệu từ nhiều file vào một file "TH" chứa các sheet tương ứng MS1,MS2
Mong anh chị em giải pháp chỉnh sửa giúp đoạn code:
	
	
	
		
				
			Mong anh chị em giải pháp chỉnh sửa giúp đoạn code:
		Mã:
		
	
	Sub TongHop()
    Dim cnn As Object, lsSQL As String, lrs As Object, Fname
    Dim Fso As Object, Link As String, shNameNguon, shNameDich, i As Long
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("ADODB.Connection")
    Set lrs = CreateObject("ADODB.Recordset")
    shNameNguon = Array("NGAY_1", "NGAY_2")
    shNameDich = Array("MS1", "MS2")
    Application.ScreenUpdating = 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(shNameNguon)
   
                lsSQL = "SELECT * FROM [" & shNameNguon(i) & "$A3:W10000]"
                lrs.Open lsSQL, cnn, 3, 1
                Sheets(shNameDich(i)).Range("A6:W50000").ClearContents
                Sheets(shNameDich(i)).Range("B50000").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
	
	
	  

