Разделить рабочий лист на несколько рабочих книг на основе уникальных значений в диапазоне

Question

Об этом спрашивали раньше, но я не нашел решения для уникальных значений, я пытаюсь разбить большой рабочий лист на рабочие книги, основанные на уникальных супервизорах столбца T, который содержит один ответственный (отношение один ко многим / несколько сотрудники для руководителя).

Мой код в настоящее время сканирует столбец T и запускает второй блок кода, чтобы сохранить и вставить строки, связанные с этим человеком, проблема в том, что циклы выполняются для каждой строки, независимо от того, повторяется ли супервизор 1000+ раз, что означает что для каждого супервизора файл создается n раза.

emp       sup
-------------------
john doe  jane q public 'specific file for this supervisor
clint     jane q public 'it should be in the same file as the prev record
jenny doe jonny cage 'in separate file

Вот мой код, основанный на нескольких ответах на SO:

Option Explicit
'Split resp data into separate columns baed on the names defined in
'a RESP on the FIRST sheet.
Sub splitRespVP()
    Dim wb As Workbook
    Dim p As Range

    'Application.ScreenUpdating = False

    Application.DisplayAlerts = False
    Application.EnableEvents = False

    For Each p In Sheets(1).Range("T2:T2201")
        Workbooks.Add
        Set wb = ActiveWorkbook
        ThisWorkbook.Activate

        WritePersonToWorkbook wb, p.Value

        wb.SaveAs ThisWorkbook.Path & "\sdoRespVP_" & p.Value
        wb.Close
    Next p
    'Application.ScreenUpdating = True
    Set wb = Nothing

    Application.DisplayAlerts = True
    Application.EnableEvents = True

End Sub

Второй цикл кода, где файл воссоздается несколько раз для каждого дублированного супервизора:

'Writes all the sales data rows belonging to a Person
'to the first sheet in the named respWB.
Sub WritePersonToWorkbook(ByVal respWB As Workbook, _
                          ByVal Person As String)
    Dim rw As Range
    Dim personRows As Range     'Stores all of the rows found
    Dim firstRW As Range        'containing Person in column 1
    For Each rw In UsedRange.Rows
        If Person = rw.Cells(2, 20) Then
            If personRows Is Nothing Then
                Set personRows = rw
                'Set personRows = Union(personRows, rw)
            Else
                Set personRows = Union(personRows, rw)
            End If
        End If
    Next rw

    personRows.Copy respWB.Sheets(1).Cells(1, 1) ' ACA ESTÀ EL ERROR
    Set personRows = Nothing
End Sub

Я стараюсь не зацикливать каждую строку и работать с уникальными значениями.

Answer 1

Использовал словарь и, используя каждое уникальное значение, я перебирал код, и пока он работал быстро:

Option Explicit
'Split resp data into separate columns baed on the names defined in
'a RESP on the FIRST sheet.
Sub splitRespVP()
    Dim wb As Workbook
    Dim p As Range

    Application.ScreenUpdating = False

    '''''''''''
    Dim key As Variant
    Dim d As Object, i As Long, lr As Long
    Set d = CreateObject("Scripting.Dictionary")
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To lr
      d.Item(Range("T" & i).Value) = 1
    Next i
    '''''''''''

    Application.DisplayAlerts = False
    Application.EnableEvents = False

    For Each key In d.Keys()
        Workbooks.Add
        Set wb = ActiveWorkbook
        ThisWorkbook.Activate

        WritePersonToWorkbook wb, key 'd.Item

        wb.SaveAs ThisWorkbook.Path & "\sdoRespVP_" & key
        wb.Close
    Next key
    Application.ScreenUpdating = True
    Set wb = Nothing

    Application.DisplayAlerts = True
    Application.EnableEvents = True

End Sub

'Writes all the sales data rows belonging to a Person
'to the first sheet in the named respWB.
Sub WritePersonToWorkbook(ByVal respWB As Workbook, _
                          ByVal Person As String)
    Dim rw As Range
    Dim personRows As Range     'Stores all of the rows found
    Dim firstRW As Range        'containing Person in column 1
    For Each rw In UsedRange.Rows
        If Person = rw.Cells(2, 20) Then
            If personRows Is Nothing Then
                Set personRows = rw
                'Set personRows = Union(personRows, rw)
            Else
                Set personRows = Union(personRows, rw)
            End If
        End If
    Next rw

    personRows.Copy respWB.Sheets(1).Cells(1, 1) ' ACA ESTÀ EL ERROR
    Set personRows = Nothing
End Sub