vbscript VBA EXCEL

Posted 2021-05-21

    '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

Dim numRows

    '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

Dim numCols

'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

Dim numRows

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

Dim currentPath

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

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

'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
    
    
    
unfreeze:
    Application.ScreenUpdating = True

'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

' This line both declares and assigned active worksheet to variable
Dim thisWs As Worksheet: Set thisWs = ActiveWorkbook.ActiveSheet