Copying cells with same 'Name' value, into a new workbook

[farhana13]

Hi All,

I've got a workbook that contains rows of records and need to split the records according to its 'Name', and save into a new workbook, renaming it to the 'Name'.

For example, there are 2 rows of records with the name 'Jack Russell'. Both these rows are to be copied out into a new workbook, and the new workbook to be renamed as 'Jack Russell'.
After that, there are 3 rows with the name 'Jamie Banks'. These 3 rows are to be copied out into a new workbook, and the new workbook to be renamed 'Jamie Banks'. And it carries on for all the other names until the end of the list.

As attached, is a small sample of the data.

Would be really, really thankful for anyone's help

 

[Smallman]

Hi Farhana

Welcome to the Chandoo Forum.

I opend your file and saw no such names (Jack Russel, Jamie Banks?). You most likely mean column B but please make your file match the description. This avoids confusion.

Take care

Smalman

 

[farhana13]

Hi Smallman,

Yes, column B. Very sorry for the confusion. Its a very huge file with over 600+ rows. The file that i attached is just a small sample. In the first post I should have put in the names that exist in the file i attached.

Apologies for the confusion and inconvenience.

Kind regards,
Farhana

 

[Marc L]

Hi !

With sorted names, try this :​

Sub Demo()
    If Workbooks.Count > 1 Then Beep: Exit Sub
    Application.ScreenUpdating = False

    With Sheet1.Cells(2).CurrentRegion
            CC& = .Columns.Count:  R& = 7

        Do Until R > .Rows.Count
            D& = 1
            N$ = .Cells(R, 2).Value
            While .Cells(R + D, 2).Value = N:  D = D + 1:  Wend
            Workbooks.Add
            ActiveWorkbook.ActiveSheet.Cells(2, 1).Resize(D, CC).Value = .Rows(R).Resize(D).Value
            Application.DisplayAlerts = False
            ActiveWorkbook.Close True, ThisWorkbook.Path & Application.PathSeparator & N
            Application.DisplayAlerts = True
            R = R + D
        Loop
    End With
End Sub

Do you like it ? So thanks to click on bottom right Like !
​

 

[farhana13]

Hi Marc L,

Thank you very,very much!

I've been meddling with this file for a week and thought of learning VBA from scratch, but this task was overwhelming for me.

If it isn't too much to ask, is it possible for the header of the table to be included in each of the new excel workbooks?

Many thanks,
Farhana

 

[Marc L]

Try this !​

Sub Demo()
    Application.ScreenUpdating = False

    With Sheet1.Cells(2).CurrentRegion
        R& = 7:   RC& = .Rows.Count

        Do Until R > RC
            N$ = .Cells(R, 2).Value
            .Parent.Copy

            With ActiveWorkbook.ActiveSheet
                .Columns(2).AutoFilter 1, "<>" & N
                .Rows(7).Resize(RC - 6).Delete xlUp
                .Columns(2).AutoFilter
                .Cells(1).Select
                 Application.DisplayAlerts = False
                .Parent.Close True, ThisWorkbook.Path & Application.PathSeparator & N
                 Application.DisplayAlerts = True
            End With
          
            Do:  R = R + 1:  Loop While .Cells(R, 2).Value = N
        Loop
    End With
End Sub

You like ? So thanks …

__________________
Je suis Charlie
​

 

[farhana13]

Hi Marc L,

Thank you so much for helping me with this

It comes out exactly as what i pictured it, excellent!

Thanks a million,
Farhana

 

[Marc L]

Thanks !

I just started this code by using inner Excel Macro recorder !
As you should …
​