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: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.
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & a(i, 1) & ".xlsx"
ActiveWorkbook.SaveAs "C:\Top Folder\Sub Folder\" & a(i, 1) & ".xlsx"
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.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:
where "ThisWorkbook.Path" specifies the current folder, you need something like this instead:VBA Code:ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & 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.VBA Code:ActiveWorkbook.SaveAs "C:\Top Folder\Sub Folder\" & a(i, 1) & ".xlsx"
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
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.It Works like as expected. Thanks Kevin for your super help.