Sub XYZ()
Dim Fso As Object, ObjFoder As Object, ObjFile As Object, Arr()
Dim MyFolder$, FileName$, AddRess$
Call TangToc(False)
Arr = Sheets("DiaChi").Range("B7:D27").Value
Set Fso = CreateObject("Scripting.FileSystemObject")
MyFolder = GetMyFolder()
If MyFolder = Empty Then MsgBox ("Phai chon Folder"): Exit Sub
Set ObjFoder = Fso.GetFolder(MyFolder)
For Each ObjFile In ObjFoder.Files
FileName = ObjFile.Name
If Left(FileName, 1) <> "~" And FileName <> ThisWorkbook.Name And Fso.GetExtensionName(ObjFile) Like "xls*" Then
FileName = MyFolder & "\" & FileName
Call ADO(Arr, FileName, AddRess)
End If
Next
Application.ScreenUpdating = True
Set Fso = Nothing: Set ObjFoder = Nothing: Set ObjFile = Nothing
Call TangToc(True)
End Sub
Private Sub ADO(ByRef Arr, ByVal FileName$, ByVal AddRess$)
Dim cn As Object, rs As Object, i&, eRow&, tArr, S
On Error Resume Next
Set cn = CreateObject("ADODB.Connection")
If Application.Version < 12 Then
cn.Open ("provider=Microsoft.Jet.OLEDB.4.0;data source=" & FileName & ";mode=Read;extended properties=""Excel 8.0;hdr=no;imex=1"";")
Else
cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & FileName & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
End If
With Sheets("TH")
eRow = .Range("C1000000").End(xlUp).Row + 1
S = Split(FileName, ".")
S = Split(S(UBound(S) - 1), "\")
.Range("C" & eRow).Value = S(UBound(S))
For i = 1 To UBound(Arr)
AddRess = "[" & Arr(i, 2) & "$" & Arr(i, 3) & ":L6" & "]"
Set rs = cn.Execute("select * from " & AddRess)
If Not rs.EOF Then
tArr = rs.GetRows
.Range(Arr(i, 1) & eRow).Value = tArr(0, 0)
End If
rs.Close
Next i
End With
cn.Close
Set rs = Nothing: Set cn = Nothing
End Sub
Private Function GetMyFolder(Optional strPath As String = Empty) As String
Dim Fldr As FileDialog
Set Fldr = Application.FileDialog(msoFileDialogFolderPicker)
With Fldr
.Title = "Chon Folder chua các file can tong hop"
.AllowMultiSelect = False
.InitialFileName = strPath
.Show
If .SelectedItems.Count > 0 Then GetMyFolder = .SelectedItems(1)
End With
Set Fldr = Nothing
End Function
Private Sub TangToc(t As Boolean)
Application.DisplayAlerts = t
Application.ScreenUpdating = t
If t = True Then Application.Calculation = xlCalculationAutomatic Else Application.Calculation = xlCalculationManual
Application.AskToUpdateLinks = t
End Sub
