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.

 

[PeteWright]

@Vivek786 You should be more specific with what you want to achieve, please provide some more details.

 

[Vivek786]

For an example i have data under columns bifurcated between Country Names.
LIke 500 rows for India , 500 rows of data for Japan.
So i was looking for Macro where all rows of data belong to Country India gets seperated and auto save the file name with India.

Same for Japan should create seperate excel file with rows of data belongs to Japan.

 

[kevin9999]

Please post a copy of your sheet using the XL2BB - Excel Range to BBCode or alternatively, share your file via DropBox, Google Drive or similar file sharing site.

 

[kevin9999]

In the absence of a definitive sample of your data layout, here's a possibility that works on a test file I created with before & after running the code. Obviously, much will need to be adjusted once your actual sheet layout is known...

Option Explicit
Sub SplitCountries()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, ws2 As Worksheet, LRow As Long, LCol As Long
    Set ws = Worksheets("Sheet1")   '<~~ *** Change to actual source sheet name ***
    LRow = ws.Cells(Rows.Count, "A").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("A2", Cells(Rows.Count, "A").End(xlUp))
        For Each c In Split(r, ",")
            d(c) = 1
        Next c
    Next r
    a = Application.Transpose(d.keys)
    b = ws.Range("A2", Cells(Rows.Count, "A").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
        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
        ActiveWorkbook.Close True
    Next i
    Application.ScreenUpdating = True
End Sub

Original test sheet:

Vivek786.xlsm
	A	B	C
1	HDR1	HDR2	HDR3
2	India	India	India
3	Japan	Japan	Japan
4	India	India	India
5	India	India	India
6	India	India	India
7	Japan	Japan	Japan
8	Japan	Japan	Japan
9	Japan	Japan	Japan
10	India	India	India
11	Japan	Japan	Japan
Sheet1

India file created:

India.xlsx
	A	B	C
1	HDR1	HDR2	HDR3
2	India	India	India
3	India	India	India
4	India	India	India
5	India	India	India
6	India	India	India
7
Sheet1

Japan file created:

Japan.xlsx
	A	B	C
1	HDR1	HDR2	HDR3
2	Japan	Japan	Japan
3	Japan	Japan	Japan
4	Japan	Japan	Japan
5	Japan	Japan	Japan
6	Japan	Japan	Japan
7
Sheet1

 

[Vivek786]

Hi Attaching actual work file here. There is one sheet called All Data in that there is column Y based on that excel files need to be created.
In the same attachment i had bifurcated the sheet manually and named the sheet manually as well.
Your help i want is to create seperate excel files and excel file to be named as per records.

Dropbox - File Deleted - Simplify your life

www.dropbox.com

 

[kevin9999]

Hi Attaching actual work file here. There is one sheet called All Data in that there is column Y based on that excel files need to be created.
In the same attachment i had bifurcated the sheet manually and named the sheet manually as well.
Your help i want is to create seperate excel files and excel file to be named as per records.

Dropbox - File Deleted - Simplify your life

www.dropbox.com

Thank you for providing the file. So with that file, there would only be 2 new files created based on the only 2 unique entries in column Y. Is that correct?

 

[Vivek786]

Thank you for providing the file. So with that file, there would only be 2 new files created based on the only 2 unique entries in column Y. Is that correct?

Yes. I have like that 15-18 different data sets, so when you will help me to create macros i will use for my entire data set.

 

[kevin9999]

See if this gives you what you want (I've also shared the file below)
Sample Code.xlsm

Option Explicit
Sub Split_Column_Y()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, ws2 As Worksheet, LRow As Long, LCol 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
        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 ActiveWorkbook
            .Worksheets(1).Name = a(i, 1)
            .Worksheets(1).Columns(LCol).Offset(, -1).EntireColumn.Delete
            .Close True
        End With
    Next i
    Application.ScreenUpdating = True
End Sub

 

[Vivek786]

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.