Creating Multiple Excel Files from the list of values in cells

[Vivek786]

Hello,
Please help me to create macro where i need to create multiple excel files- please i dont wantto create multiples sheets. based on the cells value.

 

[kevin9999]

Hi Kevin. Its really working and creating the files based on the cells value.
2 Queries i have
1. The excel files which got generated how to define path where we can save it/ how to define the folder names?
2. At the end of each files we need sum of pcs/ cts and total list value.

1. You need to specify the location within the code, so instead of the current line (which saves the newly created files to the folder this code file is in) which is this:

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & a(i, 1) & ".xlsx"

where "ThisWorkbook.Path" specifies the current folder, you need something like this instead:

ActiveWorkbook.SaveAs "C:\Top Folder\Sub Folder\" & a(i, 1) & ".xlsx"

and you can add as many subfolders as you like. I've added that line to the code below (and in the linked file) to show you where - just delete the "ThisWokbook.Path" line once you've added the new location save line.

2. Done - code added to Sum the appropriate columns

Sample Code.xlsm

Option Explicit
Sub Split_Column_Y_V2()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, ws2 As Worksheet, LRow As Long, LCol As Long, LRowSplit As Long
    Set ws = Worksheets("ALL DATA")     '<~~ *** Make sure sheet name is correct ***
    LRow = ws.Cells(Rows.Count, "Y").End(xlUp).Row
    LCol = ws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
    
    Dim d As Object, r As Range, a, b, c, x, z As Long, i As Long, j As Long
    Set d = CreateObject("scripting.dictionary")
    For Each r In Range("Y2", Cells(Rows.Count, "Y").End(xlUp))
        For Each c In Split(r, ",")
            d(c) = 1
        Next c
    Next r
    a = Application.Transpose(d.keys)
    b = ws.Range("Y2", Cells(Rows.Count, "Y").End(xlUp))
    
    For i = LBound(a) To UBound(a)
        ReDim x(1 To UBound(b, 1), 1 To 1)
        For j = 1 To UBound(b, 1)
            If b(j, 1) <> a(i, 1) Then x(j, 1) = 1
        Next j
        
        ws.Copy
        Application.DisplayAlerts = False
        
        '*** To save to a specific location, use something like this:
        'ActiveWorkbook.SaveAs "C:\Top Folder\Sub Folder\" & a(i, 1) & ".xlsx"
        
        'Whereas this saves to the same folder THIS code file is in:
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & a(i, 1) & ".xlsx"
        
        Application.DisplayAlerts = True
        Set ws2 = ActiveWorkbook.Worksheets(1)
        
        ws2.Cells(2, LCol).Resize(UBound(x)).Value = x
        z = WorksheetFunction.Sum(ws2.Columns(LCol))
        If z > 0 Then
            ws2.Range(ws2.Cells(2, 1), ws2.Cells(LRow, LCol)).Sort Key1:=ws2.Cells(2, LCol), _
            order1:=xlAscending, Header:=xlNo
            ws2.Cells(2, LCol).Resize(z).EntireRow.Delete
        End If
        With ws2
            .Name = a(i, 1)
            .Columns(LCol).Offset(, -1).EntireColumn.Delete
            LRowSplit = .Cells.Find("*", , xlFormulas, , 1, 2).Row + 2
            .Range("A1:X1").Copy
            .Range("A" & LRowSplit).PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
            .Range("F" & LRowSplit).Formula = "=sum(F2:F" & LRowSplit - 2 & ")"
            .Range("G" & LRowSplit).Formula = "=sum(G2:G" & LRowSplit - 2 & ")"
            .Range("U" & LRowSplit).Formula = "=sum(U2:U" & LRowSplit - 2 & ")"
            Application.Goto .Range("A1"), scroll:=True
        End With
        ActiveWorkbook.Close True
    Next i
    Application.ScreenUpdating = True
End Sub

 

[Vivek786]

1. You need to specify the location within the code, so instead of the current line (which saves the newly created files to the folder this code file is in) which is this:

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & a(i, 1) & ".xlsx"

where "ThisWorkbook.Path" specifies the current folder, you need something like this instead:

ActiveWorkbook.SaveAs "C:\Top Folder\Sub Folder\" & a(i, 1) & ".xlsx"

and you can add as many subfolders as you like. I've added that line to the code below (and in the linked file) to show you where - just delete the "ThisWokbook.Path" line once you've added the new location save line.

2. Done - code added to Sum the appropriate columns

Sample Code.xlsm

Option Explicit
Sub Split_Column_Y_V2()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, ws2 As Worksheet, LRow As Long, LCol As Long, LRowSplit As Long
    Set ws = Worksheets("ALL DATA")     '<~~ *** Make sure sheet name is correct ***
    LRow = ws.Cells(Rows.Count, "Y").End(xlUp).Row
    LCol = ws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
   
    Dim d As Object, r As Range, a, b, c, x, z As Long, i As Long, j As Long
    Set d = CreateObject("scripting.dictionary")
    For Each r In Range("Y2", Cells(Rows.Count, "Y").End(xlUp))
        For Each c In Split(r, ",")
            d(c) = 1
        Next c
    Next r
    a = Application.Transpose(d.keys)
    b = ws.Range("Y2", Cells(Rows.Count, "Y").End(xlUp))
   
    For i = LBound(a) To UBound(a)
        ReDim x(1 To UBound(b, 1), 1 To 1)
        For j = 1 To UBound(b, 1)
            If b(j, 1) <> a(i, 1) Then x(j, 1) = 1
        Next j
       
        ws.Copy
        Application.DisplayAlerts = False
       
        '*** To save to a specific location, use something like this:
        'ActiveWorkbook.SaveAs "C:\Top Folder\Sub Folder\" & a(i, 1) & ".xlsx"
       
        'Whereas this saves to the same folder THIS code file is in:
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & a(i, 1) & ".xlsx"
       
        Application.DisplayAlerts = True
        Set ws2 = ActiveWorkbook.Worksheets(1)
       
        ws2.Cells(2, LCol).Resize(UBound(x)).Value = x
        z = WorksheetFunction.Sum(ws2.Columns(LCol))
        If z > 0 Then
            ws2.Range(ws2.Cells(2, 1), ws2.Cells(LRow, LCol)).Sort Key1:=ws2.Cells(2, LCol), _
            order1:=xlAscending, Header:=xlNo
            ws2.Cells(2, LCol).Resize(z).EntireRow.Delete
        End If
        With ws2
            .Name = a(i, 1)
            .Columns(LCol).Offset(, -1).EntireColumn.Delete
            LRowSplit = .Cells.Find("*", , xlFormulas, , 1, 2).Row + 2
            .Range("A1:X1").Copy
            .Range("A" & LRowSplit).PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
            .Range("F" & LRowSplit).Formula = "=sum(F2:F" & LRowSplit - 2 & ")"
            .Range("G" & LRowSplit).Formula = "=sum(G2:G" & LRowSplit - 2 & ")"
            .Range("U" & LRowSplit).Formula = "=sum(U2:U" & LRowSplit - 2 & ")"
            Application.Goto .Range("A1"), scroll:=True
        End With
        ActiveWorkbook.Close True
    Next i
    Application.ScreenUpdating = True
End Sub

It Works like as expected. Thanks Kevin for your super help.

 

[kevin9999]

Happy to help & welcome to the forum! Thanks for the feedback

 

[Peter_SSs]

It Works like as expected. Thanks Kevin for your super help.

The marked solution has been changed accordingly. In your future questions, please mark the post as the solution that actually answered your question, instead of your feedback message as it will help future readers. No further action is required for this thread.