VBA to Save workbook in multiple folder based on specific sub folder name

[Abhishekghorpade]

Hi,

I have a workbook named "2020Help". I need to save this file in almost 2000+ folders. folder name is not unique but the subfolder name is "2020help".
is there a way to search the sub folder name and save the file in it.

Any help will be greatly appreciated

 

[Takae]

Please set "Sheet1" and "Sheet2" before run the macro(test()).
Hope this helps.

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