为关系表创建一个名为“组”的工作表。生成一个用于筛选条件的公司名称数组。

Option Explicit

Sub Step1_split()

    Dim wb As Workbook, wsGroups As Worksheet
    Dim wsSrc As Worksheet, wsTarget As Worksheet
    
    Dim rngFilter As Range, rngCopy As Range
    Dim lastrow As Long, r As Long, grp As String
    Dim i As Long, n As Long, arCrit, vcol
    
    Set wb = ThisWorkbook
    With wb
         Set wsSrc = .Sheets(1) '.ActiveSheet
         Set wsGroups = .Sheets("Groups") ' as req
    End With
    
    vcol = Application.InputBox( _
        prompt:="Which column would you like to filter by ?", _
        title:="Filter column", Default:="2", Type:=1)
        
    If vcol = "False" Then Exit Sub ' cancel
    
    ' filter range
    With wsSrc
         lastrow = .Cells(.Rows.Count, vcol).End(xlUp).Row
         Set rngFilter = .Cells(1, vcol).Resize(lastrow)
         Set rngCopy = .Cells(1, 1).Resize(lastrow)
        .AutoFilterMode = False
    End With
    
    ' get parent-company details
    Dim dict As Object, k
    Set dict = CreateObject("Scripting.Dictionary")
    
    With wsGroups
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For r = 2 To lastrow
            grp = Trim(.Cells(r, "B"))
            If Not dict.exists(grp) Then
               dict.Add grp, New Collection
            End If
            dict(grp).Add Trim(.Cells(r, "A"))
        Next
    End With
    
    ' create sheet for each group, clear existing
    Application.ScreenUpdating = False
    i = wb.Sheets.Count
    For Each k In dict.keys
        grp = Replace(CStr(k), "'", "") ' take out single quotes
      
        On Error Resume Next
        Set wsTarget = wb.Sheets(grp)
        On Error GoTo 0
        If wsTarget Is Nothing Then
            wb.Sheets.Add(after:=wb.Sheets(i)).Name = grp
            i = i + 1
            Set wsTarget = wb.Sheets(i)
        Else
            wsTarget.Cells.Clear
        End If
        
        ' create aray
        ReDim arCrit(0 To dict(k).Count - 1)
        For n = 1 To dict(k).Count
            arCrit(n - 1) = dict(k)(n)
        Next
        'Debug.Print k, Join(arCrit, ";")
    
        ' filter with array as criteria and copy
        With rngFilter
             .AutoFilter Field:=1, Criteria1:=arCrit, _
                         Operator:=xlFilterValues
             rngCopy.Copy wsTarget.Range("A1")
        End With
        Set wsTarget = Nothing
    
    Next
    wsSrc.AutoFilterMode = False
    Application.ScreenUpdating = True
    MsgBox "Done"
   
End Sub