Option Explicit
Sub Main()
Dim FSo As Object, strFolder$, sFolder As Object, aFolder()
Dim rngP As Range, rngS As Range, i&, k&
'On Error Resume Next
Set FSo = CreateObject("Scripting.FileSystemObject")
strFolder = GetFolder()
If strFolder = Empty Then Exit Sub
Dulieu_P.UsedRange.ClearContents
Dulieu_S.UsedRange.ClearContents
Set rngP = Dulieu_P.Range("B2")
Set rngS = Dulieu_S.Range("B2")
For Each sFolder In FSo.GetFolder(strFolder).SubFolders
k = k + 1
ReDim Preserve aFolder(1 To k)
aFolder(k) = sFolder
Next
Call SortIndex(aFolder, k, True, True, ".")
For i = LBound(aFolder) To UBound(aFolder)
If FSo.FolderExists(aFolder(i) & "\P") Then
Call GetTxtFile(rngP, FSo, aFolder(i) & "\P")
End If
If FSo.FolderExists(aFolder(i) & "\S") Then
Call GetTxtFile(rngS, FSo, aFolder(i) & "\S")
End If
Next
End Sub
Private Sub GetTxtFile(rng, FSo, ByVal iPath$)
Dim oFile As Object, TS As Object, aFile(), q&, r&, fileName$
For Each oFile In FSo.GetFolder(iPath).files
q = q + 1
ReDim Preserve aFile(1 To q)
aFile(q) = oFile
Next
Call SortIndex(aFile, q, True, True, ".")
For r = LBound(aFile) To UBound(aFile)
If UCase(FSo.GetExtensionName(aFile(r))) Like "TXT" Then
Set TS = FSo.OpenTextFile(aFile(r), 1, , -2)
'aFile(r) = FSo.GetBaseName(aFile(r)) 'Chi lay ten file
Call ImportTextFiles(rng, TS, aFile(r), 0)
End If
Next
End Sub
Private Sub ImportTextFiles(ByRef rng, ByRef TS, ByVal fileName, ByVal k&)
Dim arr(), lines, items, r&, C&, linecount&, text$
lines = Split(TS.ReadAll, vbCrLf)
If UBound(lines) > 0 Then
linecount = UBound(lines)
ReDim arr(1 To linecount, 1 To 1)
For r = 1 To linecount
text = lines(r)
If text <> "" Then
If text <> String(Len(text), vbTab) Then
k = k + 1
items = Split(text, vbTab)
If UBound(arr, 2) < UBound(items) + 1 Then ReDim Preserve arr(1 To linecount, 1 To UBound(items) + 1)
For C = 1 To UBound(arr, 2)
arr(k, C) = items(C - 1)
Next C
End If
End If
Next r
End If
If k Then
rng.Offset(, -1).Resize(k).Value = fileName
rng.Resize(k, UBound(arr, 2)).Value = arr
Set rng = rng.Offset(k + 1)
End If
End Sub
Private Sub SortIndex(sArr, ByVal eR&, Optional ByVal bASC As Boolean = True _
, Optional ByVal bIndex As Boolean = False, Optional ByVal deli$ = ".")
' Mac dinh bASC=True, neu bASC=True: A->Z , bASC=False: Z->A
' bIndex=True: Sort voi Chi Muc dau chuoi ky tu, mac dinh = False
' deli: Ky tu phan cap Chi Muc, mac dinh = "."
Dim arr, C&(), tmp$, sRow&, fR&, i&, r&
fR = LBound(sArr)
If bIndex = False Then
arr = sArr
Else
Call CreateArr(sArr, arr, fR, eR, deli)
End If
ReDim C(fR To eR)
For i = fR To eR - 1
tmp = arr(i)
For r = i + 1 To eR
If (tmp > arr(r)) = bASC Then C(i) = C(i) + 1 Else C(r) = C(r) + 1
Next r
Next i
If bIndex = True Then arr = sArr
For i = fR To eR
sArr(C(i) + fR) = arr(i)
Next i
End Sub
Private Sub CreateArr(sArr, arr, fR, eR, deli$)
Dim S, a(), t&(), tmp$, i&, j&
ReDim t(0 To 9) 'Toi da 9+1=10 Cap Chi Muc
ReDim a(fR To eR, 1 To 2)
ReDim arr(fR To eR)
For i = fR To eR
S = Split(sArr(i), "\")
tmp = S(UBound(S)) 'Ten thu muc hoac ten file
S = Split(tmp & " ", " ")
a(i, 1) = S(0)
If UBound(S) > 1 Then a(i, 2) = Replace(tmp, a(i, 1) & " ", "")
S = Split(a(i, 1), deli)
For j = 0 To UBound(S)
If t(j) < Len(S(j)) Then t(j) = Len(S(j))
Next j
a(i, 1) = S
Next i
For i = fR To eR
S = a(i, 1)
For j = 0 To UBound(S)
If IsNumeric(S(j)) Then S(j) = Format(CLng(S(j)), String(t(j), "0"))
Next j
If a(i, 2) = Empty Then
arr(i) = Join(S, deli)
Else
arr(i) = Join(S, deli) & " " & a(i, 2)
End If
Next i
End Sub
Function GetFolder(Optional strPath As String = Empty) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Chon Folder chua các file cân tông hop"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show = -1 Then GetFolder = .SelectedItems(1)
End With
End Function
