Creating Multiple Excel Files from the list of values in cells

Vivek786

New Member
Joined
Apr 25, 2023
Messages
27
Office Version
  1. 2011
Platform
  1. Windows
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.
 
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:
VBA Code:
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & a(i, 1) & ".xlsx"
where "ThisWorkbook.Path" specifies the current folder, you need something like this instead:
VBA Code:
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

VBA Code:
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
 
Upvote 0
Solution

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
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:
VBA Code:
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & a(i, 1) & ".xlsx"
where "ThisWorkbook.Path" specifies the current folder, you need something like this instead:
VBA Code:
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

VBA Code:
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.
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,224,522
Messages
6,179,297
Members
452,903
Latest member
Knuddeluff

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top