Sub Test()
Dim File, Files, LR&, LR_KQ&, LR_TH&, LC%, R&, C%, K&, Arr, tArr()
Dim TH As Worksheet, WS As Worksheet, WB As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Const CR = 12, nWS = "TongHop"
On Error Resume Next
Set TH = ThisWorkbook.Worksheets(nWS)
If Err Then: Set TH = Application.Workbooks.Add: TH.Name = nWS
R = TH.Range("A" & Rows.Count).End(xlUp).Row
If R > CR Then TH.Range("A" & CR + 1).Resize(Rows.Count - CR, 1).ClearContents
Err.Clear
ListAllFiles ThisWorkbook.Path, , Files, False, ".xls*"
If Not IsArray(Files) Then Exit Sub
For Each File In Files
Set WS = Nothing
Set WB = Application.Workbooks(File)
If Err Then Set WB = Application.Workbooks.Open(File, , True)
Err.Clear
For Each WS In WB.Worksheets
If Not WS.Name Like "*(*)*" And LCase(WS.Name) Like "ket qua kt*" Then Exit For
Set WS = Nothing
Next WS
If Not WS Is Nothing Then
LR_KQ = WS.Range("A" & Rows.Count).End(3).Row - CR
If LC <= 0 Then LC = WS.Cells(CR - 1, Columns.Count).End(xlToLeft).Column
If LR_KQ > 0 And LC > 0 Then
If LR = 0 Then
Application.CutCopyMode = False
WS.Range("A" & CR - 3).Resize(4, LC).Copy TH.Range("A" & CR - 3).Resize(4, LC)
TH.Range("A" & CR - 3).Resize(4, LC).value = TH.Range("A" & CR - 3).Resize(4, LC).value2
Application.CutCopyMode = True
End If
ReDim Preserve tArr(1 To LC, 1 To LR + LR_KQ)
Arr = WS.Range("A" & CR + 1).Resize(LR_KQ, LC).Value2
For C = 1 To LC
For R = LR + 1 To LR + LR_KQ
tArr(C, R) = Arr(R - LR, C)
If C = 1 Then: K = K + 1: tArr(C, R) = K
Next R
Next C
LR = LR + LR_KQ
End If
End If
WB.Close False
Set WB = Nothing
Next
On Error GoTo 0
If LR > 0 And LC > 0 Then
ReDim Total(1 To LR, 1 To LC)
For R = 1 To LR: For C = 1 To LC
Total(R, C) = tArr(C, R)
Next C, R
TH.Range("A" & CR + 1).Resize(LR, LC).Value = Total
TH.Activate
End If
Set WS = Nothing: Set TH = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub ListAllFiles(ByVal aFolder, _
Optional ByRef FSO As Object, _
Optional ByRef Files As Variant, _
Optional ByVal IncludeSubfolders As Boolean, _
Optional ByVal Types = "*.*", _
Optional ByVal NameTypes = "", _
Optional ByVal iShortPart As Boolean)
If TypeName(aFolder) = "String" Then aFolder = Array(aFolder)
Dim I&, K&, T$, T2$
Dim aTypes(), Arr(), dArr()
Dim SF, Item, Folder, sFolder
I = -1
If TypeName(NameTypes) = "String" Then
If NameTypes <> vbNullString Then I=I+1:ReDim aTypes(I): aTypes(I) = LCase(NameTypes)
Else
ReDim aTypes(UBound(NameTypes))
For I = LBound(Files) To UBound(Files): Arr(I) = LCase(NameTypes(I)): Next I
End If
If TypeName(Types) = "String" Then
If Types <> vbNullString Then
I = I + 1
ReDim Preserve aTypes(I+1)
aTypes(I+1) = "*" & LCase(Types)
End If
Else
ReDim Preserve aTypes(UBound(Types) + IIf(I = -1, 0, I))
For K = LBound(Types) To UBound(Types): aTypes(K + IIf(I = -1, 0, I)) = "*" & LCase(Types(K)): Next K
End If
If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
I = -1: K = 0
If IsArray(Files) Then
ReDim Arr(UBound(Files))
For I = LBound(Files) To UBound(Files): Arr(I) = Files(I): Next I
End If
For Each Folder In aFolder
If FSO.FolderExists(Folder) Then
Set sFolder = FSO.GetFolder(Folder)
For Each Item In sFolder.Files
T = vbNullString: T = LCase(Item.Name)
T2 = vbNullString: T2 = LCase(Item.Type)
For Each SF In aTypes
If Left(T, 1) <> "~" And (T Like SF Or T2 Like SF) Then
I = I + 1: ReDim Preserve Arr(I): Arr(I) = IIf(iShortPart, Item.ShortPath, Item.Path)
Exit For
End If
Next SF
Next Item
If IncludeSubfolders Then
For Each SF In sFolder.SubFolders
ReDim Preserve dArr(K): dArr(K) = SF.Path: K = K + 1
Next SF
End If
End If
Next Folder
Files = Arr
If IncludeSubfolders Then
ListAllFiles dArr, FSO, Files, True, Types, NameTypes, iShortPart
End If
End Sub
