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

根据范围内的唯一值在多个工作簿中拆分工作表

1 个答案: