Copying Dynamic Rows Into New Workbook and save it

Question

I'm new in here. I have search for a solution but i could find exactly what i needed.

I found part of my answer in this post : Copying Dynamic Cells/Rows Into New Sheet or Workbook

But there is 2 more specific actions that i need and i cant figure it out in a good way. First thing I would like to save the new workbooks with the name of the "key" at the same place that the original file. Second thing is to copy also the first line to every new workbooks. Here my example : In my DB, the key are sorted so all the alpha are together and the bravo and the rest...

ORIGINAL DATABASE (DB):

Name    Position    Key
Bruce   1           Alpha
Bruce   2           Alpha
Alfred  2           Alpha
Alfred  3           Bravo
Robin   1           Bravo
Robin   1           Bravo

In the first Workbook i would like:

Name    Position   Key
Bruce   1          Alpha
Bruce   2          Alpha
Alfred  2          Alpha

And i would like this workbook to be save as "Alpha.xlsx" in the same directory that the original database (in a file on the desktop) and then that he close the window

Then the 2nd workbook would be

Name    Position  Key
Alfred  3         Bravo
Robin   1         Bravo
Robin   1         Bravo

Saved with the name "Bravo.xlsx" also in the same file on my desktop and close and keep going with the 400 keys

Here the code from the post that i found in the forum: The original code was written by chiliNUT I made the update to fit to my DB

Sub grabber()
Dim thisWorkbook As Workbook
Set thisWorkbook = ActiveWorkbook
last = 1
For i = 1 To 564336 'my DB had 500K rows
If Range("A" & i) <> Range("A" & (i + 1)) Then
Range("A" & last & ":N" & i).Copy
Set NewBook = Workbooks.Add
NewBook.Sheets("Feuil1").Range("A1").PasteSpecial xlPasteValues
last = i + 1
thisWorkbook.Activate
End If
Next i
End Sub

This VBA works perfectly but it doesn't copy the first line every time and do not save it. i have around 400 "keys" so it become difficult to handle manually. I'm not a specialist at all.

Can you please copy the full code in your answer so I will be able to figure it out ? Thank you in advance for your help. I read a lot of post and you always figure it out and help people. So thank you also for that.

And you probably understood that English is not my first language. Sorry for the mistake and false grammar.

Thank in advance!

Answer 1

you could do it like this (worked on my pc for the data example). remember to add microsoft scripting runtime to make the dictionary work:

Sub grabber()
    Dim thisWs As Worksheet: Set thisWs = ActiveWorkbook.ActiveSheet
    'To make dictionaries work, and the line to make sense, you need to reference Microsoft Scripting Runtime, Tools-> References, and check of "Microsoft Scripting Runtime"
    Dim myDict As New Scripting.Dictionary
    Dim pathToNewWb As String
    Dim currentPath, columnWithKey, numCols, numRows, uniqueKeys, uKey

    'to avoid the screenupdating being false in case of unforseen errors, I want the program to jump to unfreeze if errors occur
    On Error GoTo unfreeze 

    'with 400 keys it would end up with a lot of flicker + speeds it up:
    Application.ScreenUpdating = False


    'get the path of the active workbook
    currentPath = Application.ActiveWorkbook.Path

    'I hardcode the reference to the key column
    columnWithKey = 3
    'And assume that the worksheet is "just" data, why the number of used rows and columns can be used to identify the data
    numCols = thisWs.UsedRange.Columns.Count


    'extract the index of the last used row in the active sheet of the active workbook
    numRows = thisWs.UsedRange.Rows.Count

    'use a dictionary to get a list of unique keys by running over the key column in the used rows
    For i = 2 To numRows
        vKey = thisWs.Cells(i, columnWithKey)
        If Not myDict.exists(vKey) Then
            myDict.Add vKey, 1
        End If
    Next i

    uniqueKeys = myDict.keys()

    For Each uKey In uniqueKeys
        pathToNewWb = currentPath & "/" & uKey & ".xlsx"

        'Filter the keys column for a unique key
        thisWs.Range(thisWs.Cells(1, 1), thisWs.Cells(numRows, numCols)).AutoFilter field:=columnWithKey, Criteria1:=uKey

        'copy the sheet
        thisWs.UsedRange.Copy

        'Open a new workbook, chang the sheets(1) name and paste as values, before saveas and close
        Set NewBook = Workbooks.Add
        With NewBook
            .Sheets(1).Name = "Feuil1"
            .Sheets(1).Range("A1").PasteSpecial xlPasteValues
            .SaveAs pathToNewWb
            .Close
        End With

        'remove autofilter (paranoid parrot)
        thisWs.AutoFilterMode = False

    Next

    Set myDict = Nothing

unfreeze:
    Application.ScreenUpdating = True

End Sub

In adapting the code you provided, I used the following posts:

for dictionary: (Does VBA have Dictionary Structure?)

for autofilter: (VBA for filtering columns)

for SaveAs & Close: (Excel VBA Open workbook, perform actions, save as, close)