Sub TongHoploc()
'On Error GoTo PROC_ERR
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("DL")
shNameDich = Array("DLD")
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, "Thông Báo"
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 f1,f2,f3,f4 FROM [" & shNameNguon(i) & "$B4:E65536] where f1>=#" & Sheets(shNameDich(i)).[D2] & "# and f1<=#" & Sheets(shNameDich(i)).[D3] & "# group by f1,f2,f3,f4"
'
lrs.Open lsSQL, cnn, 3, 1
Sheets(shNameDich(i)).Range("A6:D12000").ClearContents
Sheets(shNameDich(i)).Range("A60000").End(3).Offset(1, 0).CopyFromRecordset lrs
lrs.Close
Next
End With
Next
End With
'PROC_EXIT:
' On Error Resume Next
Application.ScreenUpdating = True
cnn.Close
Set lrs = Nothing
Set cnn = Nothing
Exit Sub
PROC_ERR:
MsgBox "Ket noi co loi xay ra:", vbCritical
' GoTo PROC_EXIT
End Sub