VBA-split data into multiple worksheets based on column

[loop66]

Need help with splitting data from column
Steps:
1.open existing workbook
2.autofilter data(column 13) (different names: John,Emma....)
3.save into new file under filtered name (John.xlsx)
4.filter another name , save and so on for every name

i have code partial code


Dim rng01 As Range
Set rng01 = [M5:M10]
rng01.Parent.AutoFilterMode = False
rng01.Columns(13).AutoFilter Field:=1, Criteria1:="John", VisibleDropDown:=False


21531

[YasserKhalil]

Try this code


Sub Test()
Dim wb As Workbook
Dim wbTgt As Workbook
Dim dic As Object
Dim d As Variant
Dim x As Variant
Dim source As Range
Dim cel As Range
Dim tgt As Range
Dim pth As String
Dim f As String


Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
Set wb = ThisWorkbook
pth = ThisWorkbook.Path & "\"

With Sheets("Sheet1")
Set source = .Range(.Cells(5, 13), .Cells(Rows.Count, 13).End(xlUp))
On Error Resume Next
For Each cel In source.Offset(1).Cells
x = CStr(cel.Value)
If x <> "" Then dic.Add x, x
Next cel
On Error GoTo 0

For Each d In dic.keys
If Len(Dir(pth & d & ".xlsx")) Then
Else
Workbooks.Add
ActiveWorkbook.SaveAs pth & d & ".xlsx"
ActiveWorkbook.Close False
End If
Next d

Set source = .Cells(4, 13).CurrentRegion
For Each d In dic.keys
Set wbTgt = Workbooks.Open(pth & d & ".xlsx")
Set tgt = ActiveWorkbook.Sheets("Sheet1").Cells(1, 1)
ActiveWorkbook.Sheets("Sheet1").DisplayRightToLeft = False
tgt.CurrentRegion.ClearContents
source.AutoFilter 13, d
source.Resize(source.Rows.Count - 1, 14).SpecialCells(xlCellTypeVisible).Copy tgt
ActiveWorkbook.Sheets("Sheet1").Columns.AutoFit
wbTgt.Close True
source.AutoFilter
Next d
End With
Application.ScreenUpdating = True
End Sub

[loop66]

Perfect,now how can i add something similar to Workbooks.Open "C:\123.xls" to this code ,that code runs on another file?

[YasserKhalil]

I don't get your request .. Can you give more details ?

[loop66]

OK, workbook with this macro(Test1) to open another existing book(Test2-with data) in same folder and execute code on Test2 so i can get filtered data for each name in column 13
Test1(macro)->open Test2 and execute code = Result = John.xlsx,Emma.xlsx

[georgiboy]

This is what i came up with, it may not be the best solution but it seems to fit your requirements.

Place this code in a separate workbook and then point it at your "sample.xlsx" file.


Sub ExportFiltered()
Dim FrmFle As String, fWB As Workbook, fWS As Worksheet
Dim dWB As Workbook, dWS As Worksheet, tmpStr As String
Dim v As Variant, x As Long

On Error GoTo errHand
FrmFle = GetFilePath
Set fWB = Workbooks.Open(FrmFle)
Set fWS = fWB.Sheets("Sheet1")
v = fWS.Range("M5:M" & fWS.Range("A" & Rows.Count).End(xlUp).Row).Value
v = SortR(v)

For x = 1 To UBound(v)
If v(x, 1) <> tmpStr Then
Set dWB = Workbooks.Add
Set dWS = dWB.Sheets("Sheet1")
fWS.Rows(4).Copy dWS.Rows(4)
fWS.Range("A" & LBound(v) + 3 & ":N" & UBound(v) + 3).AutoFilter 13, v(x, 1)
fWS.Range("A" & LBound(v) + 4 & ":N" & UBound(v) + 3).Copy
dWS.Range("A5").PasteSpecial xlPasteValues
Application.CutCopyMode = False
dWS.Range("A:N").EntireColumn.AutoFit
dWB.SaveCopyAs fWB.Path & "\" & v(x, 1) & ".xlsx"
dWB.Close False
tmpStr = v(x, 1)
End If
Next x
fWB.Close False
Exit Sub

errHand:
MsgBox "No file was selected", vbExclamation, "Error"
End Sub

Function GetFilePath()
Dim fle As Object
Set fle = Application.FileDialog(msoFileDialogOpen)
With fle
.Title = "Select your Sample file"
If .Show <> -1 Then
Sfle = ""
Exit Function
End If
GetFilePath = .SelectedItems(1)
End With
End Function

Function SortR(r As Variant)
Dim i As Long, j As Long, Temp
For i = LBound(r) To UBound(r) - 1
For j = i + 1 To UBound(r)
If UCase(r(i, 1)) > UCase(r(j, 1)) Then
Temp = r(j, 1)
r(j, 1) = r(i, 1)
r(i, 1) = Temp
End If
Next j
Next i
SortR = r
End Function

should at least be able to amend Yasser’s code by looking at how this asks for the file to run on.

Hope this helps

[loop66]

T h n x x x