Creating new spreadsheets from a list of staff in a specific column

jaypatel

Active Member
Joined
Nov 25, 2002
Messages
389
Hi

I was wondering if its possible to do the following:

Column E is key here.

So i have a database, where firstly i wish to extract everything that belongs to Jaypatel (found in column E can be extracted to a new file named jaypatel.xlsx. So if jaypatel exists in E2, E4 and E6, it will extract Rows 2,4 and 6 into jaypatel.xlsx (and maybe copying the headers (row 1)?

Is that possible?

thanks
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Here is a quick and dirty solution...

I used the data range from A through K (A:K)
and saved the files into C:\New Folder

you might want to modify these based on your need

VBA Code:
Sub CreateWBs()
    Dim srcWB As Workbook
    Dim dstWB As Workbook
    Dim srcSh As Worksheet
    Dim dstSh As Worksheet
    
    Set srcWB = ActiveWorkbook
    Set srcSh = ActiveSheet
    
    lr = srcSh.Range("E" & Rows.Count).End(xlUp).Row
    
    If lr > 1 Then
        Application.DisplayAlerts = False
        
        For i = 2 To lr
            srcSh.Range("A:K").AutoFilter Field:=5, Criteria1:=srcSh.Range("E" & i).Value
            Set dstWB = Workbooks.Add
            dstWB.SaveAs Filename:="C:\New Folder\" & srcSh.Range("E" & i).Value & ".xlsx"
            Set dstSh = dstWB.Sheets(1)
            srcSh.Range("A:K").Copy dstSh.Range("A1")
            dstWB.Close SaveChanges:=True
        Next i
        
        Application.DisplayAlerts = True
    End If
    
    MsgBox "Done!"
End Sub
 
Upvote 0
Hi

Thanks for this...

I have tested it, and its in a unbroken loop ie, the script has not ended...

Any help is much appreciated.

thanks

Jay
 
Upvote 0
I updated it but before trying the code below please delete all the files in this folder.

VBA Code:
Sub CreateWBs()
    Dim srcWB As Workbook
    Dim dstWB As Workbook
    Dim srcSh As Worksheet
    Dim dstSh As Worksheet
    
    Set srcWB = ActiveWorkbook
    Set srcSh = ActiveSheet
    
    lr = srcSh.Range("E" & Rows.Count).End(xlUp).Row
    If lr > 1 Then

        Application.DisplayAlerts = False
        
        For i = 2 To lr
            if Dir("C:\New Folder\" & srcSh.Range("E" & i).Value & ".xlsx")="" then
            srcSh.Range("A:K").AutoFilter Field:=5, Criteria1:=srcSh.Range("E" & i).Value
            Set dstWB = Workbooks.Add
            dstWB.SaveAs Filename:="C:\New Folder\" & srcSh.Range("E" & i).Value & ".xlsx"
            Set dstSh = dstWB.Sheets(1)
            srcSh.Range("A:K").Copy dstSh.Range("A1")
            dstWB.Close SaveChanges:=True
End If
        Next i
        
        Application.DisplayAlerts = True
    End If
    
    MsgBox "Done!"
End Sub
 
Upvote 0
Power Query alternative: Open a new workbook, Connect to the other workbook, filter column E by "Jaypatel".
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,215
Members
448,554
Latest member
Gleisner2

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