Group Duplicates and move to new worksheet Closed

Question

Hello, 

I have a data file and here's what i'm trying to accomplish as efficiently and automated as possible because I will need to repeat this daily. 

Move rows that have the same value in a column, into a new worksheet. 
For example there may be 10 different values in column A. I want all rows containing the same value in column A to be extracted into a new excel workbook. In this case, there would be 10 different workbooks. Each workbook will contain all the rows that have the same value for column A.

Help is greatly appreciated.
Thanks!

vcoolio · Answer

Hello Sassylilma,

Just a little confusion here.

Move rows that have the same value in a column, into a new worksheet. 
You reference Column A as having the values so you mean that, for example,  if Column A has ten instances of the word "Apple" then a new sheet should be created (named "Apples") and the ten rows of "apples" data should be transferred to the worksheet named "Apples". Four rows of "Pear" data should be transferred to a new worksheet named "Pears" etc. etc..
This can be done fairly easily.

However, you then mention that new workbooks should be created. I assume that you still actually mean new worksheets to be created in the same workbook. Keeping all the separate values in a new worksheet for each in the same workbook would be a better and simpler option and would not be as great a drain on resource.

Could you please clarify.

Cheerio,
vcoolio.

vcoolio · Answer

Hi Sassylilma,

You're going to have a lot of workbooks! It'll be a major drain on storage and memory. However, try the following code placed in a standard module and assigned to a button:-

Sub CreateNewWbks()

Dim dic As Object, rng As Range, wks As Worksheet, mypath As String, lr As Long
    Set dic = CreateObject("scripting.dictionary")
    Set wks = Sheet1
    
mypath = ThisWorkbook.Path & "\"
lr = wks.Range("A" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

With wks
    
For nrow = lr To 2 Step -1
        If (Not dic.exists(.Cells(nrow, "A").Value)) Then
        dic.Add .Cells(nrow, "A").Value, .Cells(nrow, "A").Value
        Set rng = .Range("A1:N" & .Cells(Rows.Count, 1).End(xlUp).Row)
            rng.AutoFilter field:=1, Criteria1:=.Range("A" & nrow).Value
            rng.Copy
            Workbooks.Add
            ActiveSheet.Paste
            ActiveSheet.Columns.AutoFit
            ActiveWorkbook.SaveAs Filename:=mypath & .Range("A" & nrow).Value & ".xlsx"
            ActiveWorkbook.Close
        End If
    Next
           .AutoFilterMode = False
End With

MsgBox "Done!", vbExclamation
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

The code should create new workbooks with the relevant data in sheet1 of each workbook. The new workbooks will be saved to to the same file as the source workbook.

You may have to change the range in line 19 of the code to suit the columns that you have in your source workbook.

I hope that this helps.

Cheerio,
vcoolio.

vcoolio · Answer

BTW Sassylilma,

Please test the code in a copy of your workbook first, just in case.

Cheerio,
vcoolio.

Group Duplicates and move to new worksheet

3 responses

Similar discussions

Subscribe To Our Newsletter!