vbscript VBA准备代码

Posted 2021-05-21

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 = 17
    '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