VBA code to filter based on a column and copy in a new workbook.

[seeker123]

Hi every one I have a table like below.

Name	Category	Score
John	A	127
Mike	B	184
Jane	A	124
Fred	C	201
...	...	..

<tbody>
</tbody>

I want to separate the table based on "category column and save it in a new workbook and save the workbook to category name.
for example one of the workbooks will be "A" and it will contain

Name	Category	Score
John	A	127
Jane	A	124

<tbody>
</tbody>

How can I do that with VBA?(there are a lot of categories and using filter will took a lot of time)

Thanks a lot in advance.

 

[My Aswer Is This]

There are several questions to ask here:
1. Is the workbook name in column "B" I would assume that from your image.
2. Do you want to do this all at once or do one workbook at a time letting you choose each time which one to do using a Inputbox.

3. Will we be saving each workbook in the active workbook path? If not provide path.
4. Do you want all these workbooks saved as "xlsm"
5. Do you have a separate list of all these workbook names or must we look down column "B" and get unique names.

 

[seeker123]

Hi thanks for your reply

1.Yes it is in "Category" Column
2.All at once
3.it doesn't make any difference
4.Yes
5.the list is in column B there is not any separate list.

Thanks a lot for taking the time for answering me.

 

[My Aswer Is This]

Yes I can see it's in the "Category Column"

But is the Category column Column "B"??????
Yes or no.

 

[My Aswer Is This]

OK I see now you mean column B

Yes I can see it's in the "Category Column"

But is the Category column Column "B"??????
Yes or no.

 

[My Aswer Is This]

Try this:

Run this script from the sheet with your sheet names in column "B"
This script starts looking for sheet names on Row(2) of column (B)

Be sure you have proper names for Workbooks.

Sub Filter_Me()
Application.ScreenUpdating = False
On Error GoTo M
Dim i As Long
Dim Sn As String
Dim Lastrow As Long
Sn = ActiveSheet.Name
Dim WsName As String
Dim WbName As String
Dim ff As Long
WbName = ThisWorkbook.Name
WsName = ActiveSheet.Name
Dim FileName As String
Dim FilePath As String
FilePath = ThisWorkbook.Path
Sheets.Add(After:=Sheets(Sn)).Name = "Temp"
Sheets(Sn).Range("B1:B" & Sheets(Sn).Cells(Rows.Count, "B").End(xlUp).Row).Copy Sheets("Temp").Range("A1")
    With Workbooks(WbName).Sheets("Temp")
        .Range(.Cells(1, 1), .Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1)).RemoveDuplicates 1, xlNo
    End With
'Start Loop
Lastrow = Sheets("Temp").Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To Lastrow
FileName = Workbooks(WbName).Sheets("Temp").Range("A" & i).Value
Workbooks.Add.SaveAs FileName:=FilePath & "\" & FileName, FileFormat:=52
Workbooks(WbName).Sheets(1).Activate
    With ActiveSheet.Range(Cells(1, 2), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2))
        .AutoFilter Field:=1, Criteria1:=Sheets("Temp").Range("A" & i).Value
        .SpecialCells(xlCellTypeVisible).EntireRow.Copy Workbooks(FileName & "." & "xlsm").Sheets(1).Range("A1")
    
    End With
Workbooks(FileName & "." & "xlsm").Close SaveChanges:=True
ActiveSheet.AutoFilterMode = False
Next
'End loop
MsgBox "I will now delete a sheet named Temp I made just click Delete"
Sheets("Temp").Delete
Application.ScreenUpdating = True
Exit Sub
M:
MsgBox "We had some sort of problem maybe you already have a Workbook by that name"
End Sub

 

[My Aswer Is This]

Seeker123

Where did you go?
Gave you an answer and you never responded back.

 

[seeker123]

Sorry,
Thank you the code worked perfectely for meray:

 

[My Aswer Is This]

Glad I was able to help you. Come back here to Mr. Excel next time you need additional assistance.
I always like hearing back.