Option Explicit
Dim cnt As Long, ws1 As Worksheet, ws2 As Worksheet, i As Long, j As Long, k As Long, LR As Long, x(), z, tgtWb As Workbook
Dim buf As String, rng As Range
Sub Test()
cnt = 0
Call Sample("C:\Users\ABC\Desktop\Excel\text") ' This path is top of search path.
Call sample1
End Sub
Sub Sample(Path As String)
Dim buf As String, f As Object
With CreateObject("Scripting.FileSystemObject")
For Each f In .GetFolder(Path).SubFolders
cnt = cnt + 1
Sheets("Sheet1").Cells(cnt, 1) = f
Call Sample(f.Path)
Next f
End With
End Sub
Sub sample1()
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
cnt = 0
With ws1
For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
buf = .Cells(i, 1).Value & "\"
cnt = WorksheetFunction.Max(cnt, Len(buf) - Len(Replace(buf, "\", "")))
For j = 0 To Len(buf) - Len(Replace(buf, "\", ""))
ReDim Preserve x(j)
x(j) = Mid(buf, 1, InStr(buf, "\"))
buf = Mid(buf, InStr(buf, "\") + 1)
Next
.Range(.Cells(i, 2), .Cells(i, UBound(x) + 1)) = x
Next
.Rows(1).Insert
.Range(.Range("A1"), .Cells(1, cnt + 1)).Value = "AAA"
Set tgtWb = Workbooks.Open("C:\Users\ABC\Desktop\2020Help.xlsx") 'This full path is the path of "2020Help"
ws2.Cells.Clear
buf = ""
For i = 2 To cnt + 1
.Range("A1").AutoFilter field:=i, Criteria1:="2020help\" 'This string is sub folder's name.
If WorksheetFunction.Subtotal(3, .Columns(i)) > 1 Then
.Range("A1").CurrentRegion.Resize(, i).Copy ws2.Range("A1")
ws2.Range("A:A").ClearContents
LR = ws2.Cells(Rows.Count, 2).End(xlUp).Row
For j = 2 To LR
For k = 2 To i
ws2.Cells(j, 1).Value = ws2.Cells(j, 1).Value & ws2.Cells(j, k).Value
Next
Next
ws2.Range(ws2.Range("A2"), ws2.Cells(LR, 1).Offset(1, 0)).RemoveDuplicates Columns:=1, Header:=xlNo
For j = 2 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
Application.DisplayAlerts = False
On Error Resume Next
buf = ws2.Cells(j, 1).Value
tgtWb.SaveAs Filename:=buf & "2020Help.xlsx"
On Error GoTo 0
Application.DisplayAlerts = True
Next
End If
.Range("A1").AutoFilter
ws2.Cells.Clear
Next
tgtWb.Close
End With
End Sub