VBA code to copy and paste unique values from a data dump to new worksheet

[pxs2020]

Hi All,

Hope you all are well.

I am trying to create a VBA code to move a data dump in Excel (extracted from PowerBI), to seperate new worksheets. So for example,

if the Security Description, is the same, then all rows in the data dump to be copy and pasted into a new worksheet.

So the end result would be: Worksheet 1: Data Dump

Worksheet 2: All the rows from data dump which have Security Description "Security 1 - Description 1"

Worksheet 3: All the rows from data dump which have Security Description "Security 1 - Description 2"

Worksheet 4: All the rows from data dump which have Security Description "Security 2 - Description 1"

And so on for each unique Security Description.

Can somebody please help on this?

Thank you! Best,

 

[vcoolio]

Hello PXS,

Try the following code assigned to a button:-

Option Explicit

Sub Test()

              Dim i As Integer, lr As Long
              Dim sh As Worksheet, ws As Worksheet, ar As Variant
        
Application.ScreenUpdating = False
        
              Set sh = Sheet1 '---->Sheet code not sheet name.
              lr = sh.Range("A" & Rows.Count).End(xlUp).Row
              sh.Range("E1:E" & lr).AdvancedFilter 2, , sh.[M1], 1
              sh.Range("M2", sh.Range("M" & sh.Rows.Count).End(xlUp)).Sort [M2], 1
              ar = sh.Range("M2", sh.Range("M" & sh.Rows.Count).End(xlUp))
              
       For i = 1 To UBound(ar)
              If Not Evaluate("ISREF('" & ar(i, 1) & "'!A1)") Then
                    Sheets.Add(After:=Sheets(Worksheets.Count)).Name = ar(i, 1)
              End If
                    
              Set ws = Sheets(ar(i, 1))
              ws.UsedRange.Clear
                    
              With sh.[A1].CurrentRegion
                   .AutoFilter 5, ar(i, 1)
                   .Copy ws.[A1]
                   .AutoFilter
             End With
                   sh.Columns("M").Clear
                   ws.Columns.AutoFit
       Next i
             
Application.Goto Sheet1.[A1]
Application.ScreenUpdating = True

End Sub

This code actually creates the new sheets from the values in Column E of the Data Dump sheet. It temporarily places the unique values into Column M (by using the Advanced Filter), sorts them and then puts them into an array from which the new sheets are created. Column M is then cleared.
All sheets are cleared before each new data transfer.
I've used the sheet code for the variable sh so I'm hoping that your Data Dump sheet has the sheet code of Sheet1.

I hope that this helps.

Cheerio,
vcoolio.

 

[pxs2020]

That is perfect!! Thank you so much!

Just another question - I have another spreadsheet which is much bigger, 28 columns and 4000 rows.

I use the same code but changed range M to AD, but this time it shows Run Time Error 1004 Application defined or Object Defined error.

Is there a part of the code which needs to be adjusted for this spreadsheet?

Thanks
Best,

 

[vcoolio]

Hello PXS,
You're welcome and I'm glad that it works for you.

As for your second query, I would say that if you have simply moved the uniques from M1 to AD1 and the Security Description column is still Column E, then it may be the sheet reference giving you the error. The new worksheet will have a different sheet code. You may want to check this.
However, having said that, you could try the following code for your larger worksheet. It should be somewhat quicker:-

Option Explicit
Sub PxsTest()

        Dim sht As Worksheet, ws As Worksheet, lr As Long, i As Long
        Dim SecId As Object, key As Variant
    
        Set sht = Sheet1 '---->May need to change this to suit.
        Set SecId = CreateObject("Scripting.Dictionary")
        lr = sht.Range("A" & Rows.Count).End(xlUp).Row
    
Application.ScreenUpdating = False
        
        For i = 2 To lr
              If Not SecId.Exists(sht.Range("E" & i).Value) Then
              SecId.Add sht.Range("E" & i).Value, 1
              End If
        Next i
        
        For Each key In SecId.keys
              If Not Evaluate("ISREF('" & key & "'!A1)") Then
              Worksheets.Add(After:=Sheets(Sheets.Count)).Name = key
        End If
        
        Set ws = Sheets(key)
        ws.UsedRange.Clear
        
        With sht.[A1].CurrentRegion
              .AutoFilter 5, key
              .Copy ws.[A1]
              .AutoFilter
        End With
              ws.Columns.AutoFit
        Next key

Application.Goto sht.[A1]
Application.ScreenUpdating = True
MsgBox "All done!", vbExclamation

End Sub

This code doesn't actually extract the unique values to another column as each unique value is placed into the scripting dictionary and works directly from memory.
As noted in the code (green font), you'll need to check the sheet reference. I'm assuming that the security IDs are still in Column E.
You can, of course, adapt this version of the code to your first worksheet.

I hope that this helps.

Cheerio,
vcoolio.

 

[pxs2020]

Hi vcoolio,

Thank you so much buddy! That is perfect!!

Thank you for your help.

Best wishes to you and your family for 2022!

 

[vcoolio]

Hello PXS,

You're welcome. I'm glad to have been able to assist and thanks for the feed back.

Best wishes to you and your family as well for this new year. Stay safe.

Cheerio,
vcoolio.