Vba 为每个唯一代理创建一个新工作表，并将所有数据移动到每个工作表

我正试图解决这个问题。每天我都会收到一份包含我需要转发的数据的报告。因此，为了使它更容易一点，我试图找到一个宏，它创建了一个带有代理名称的新工作表，并在创建的工作表中移动每个代理的数据

我已经找到了一个可以做到这一点的。但由于这不是我真正的专业领域，我无法修改它来处理我的请求，甚至可能无法使它工作。有人知道吗

Const cl& = 2
Const datz& = 1

Dim a As Variant, x As Worksheet, sh As Worksheet
Dim rws&, cls&, p&, i&, ri&, j&
Dim u(), b As Boolean, y

Application.ScreenUpdating = False
Sheets("Sheet1").Activate
rws = Cells.Find("*", , , , xlByRows, xlPrevious).Row
cls = Cells.Find("*", , , , xlByColumns, xlPrevious).Column

Set x = Sheets.Add(After:=Sheets("Sheet1"))
Sheets("Sheet1").Cells(1).Resize(rws, cls).Copy x.Cells(1)
Set a = x.Cells(1).Resize(rws, cls)
a.Sort a(1, cl), 2, Header:=xlYes
a = a.Resize(rws + 1)
p = 2

For i = p To rws + 1
    If a(i, cl) <> a(p, cl) Then
        b = False
        For Each sh In Worksheets
            If sh.Name = a(p, cl) Then b = True: Exit For
        Next
        If Not b Then
            Sheets.Add.Name = a(p, cl)
            With Sheets(a(p, cl))
                x.Cells(1).Resize(, cls).Copy .Cells(1)
                ri = i - p
                x.Cells(p, 1).Resize(ri, cls).Cut .Cells(2, 1)
                .Cells(2, 1).Resize(ri, cls).Sort .Cells(2, datz), Header:=xlNo
                y = .Cells(datz).Resize(ri + 1)
                ReDim u(1 To 2 * ri, 1 To 1)
                For j = 2 To ri
                    u(j, 1) = j
                    If y(j, 1) <> y(j + 1, 1) Then u(j + ri, 1) = j
                Next j
                .Cells(cls + 1).Resize(2 * ri) = u
                .Cells(1).Resize(2 * ri, cls + 1).Sort .Cells(cls + 1), Header:=xlYes
                .Cells(cls + 1).Resize(2 * ri).ClearContents
            End With
        End If
        p = i
    End If
Next i


Application.DisplayAlerts = False
    x.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True

Const cl&=2
常数datz&=1
将a标注为变量，x标注为工作表，sh标注为工作表
尺寸rws&，cls&，p&，i&，ri&，j&
尺寸u（），b为布尔值，y
Application.ScreenUpdating=False
工作表（“工作表1”）。激活
rws=单元格。查找（“*”，xlByRows，xlPrevious）。行
cls=单元格。查找（“*”，xlByColumns，xlPrevious）。列
设置x=图纸。添加（后面：=图纸（“图纸1”））
图纸（“图纸1”）。单元格（1）。调整大小（rws、cls）。复制x。单元格（1）
设置a=x。单元格（1）。调整大小（rws、cls）
a、 排序a（1，cl），2，标题：=xlYes
a=a.调整大小（rws+1）
p=2
对于i=p至rws+1
如果a（i，cl）a（p，cl），那么
b=错误
对于工作表中的每个sh
如果sh.Name=a（p，cl），则b=True：退出
下一个
如果不是b，那么
Sheets.Add.Name=a（p，cl）
附页（a（p，cl））
x、 单元格（1）.调整大小（，cls）.复制.单元格（1）
ri=i-p
x、 单元格（p，1）。调整大小（ri，cls）。剪切。单元格（2，1）
.Cells（2，1）.调整大小（ri，cls）.排序.Cells（2，datz），标题：=xlNo
y=.Cells（datz）.调整大小（ri+1）
重读单元（1到2*ri，1到1）
对于j=2到ri
u（j，1）=j
如果y（j，1）y（j+1，1），那么u（j+ri，1）=j
下一个j
.单元格（cls+1）.调整大小（2*ri）=u
.Cells（1）.调整大小（2*ri，cls+1）.排序.Cells（cls+1），标题：=xlYes
.单元格（cls+1）.调整大小（2*ri）.清除内容
以
如果结束
p=i
如果结束
接下来我
Application.DisplayAlerts=False
x、 删除
Application.DisplayAlerts=True
Application.ScreenUpdating=True

这是我收到的报告的一个例子

我在行上不断得到错误：a。排序a（1，cl），2，标题：=xlYes 我自己也不知道它是干什么的。有人能解释一下吗

这里是一个通用模型（大量评论），它应该生成您的单个代理工作表。这将复制原始“主”工作表，并删除不属于每个代理的信息

Option Explicit

Sub agentWorksheets()
    Dim d As Long, agnt As Variant, vAGNTs As Variant, dAGNTs As Object
    Dim wsn As String, wb As Workbook

    'set special application environment
    'appTGGL bTGGL:=False   'uncomment this after debuging is complete
    Set wb = ThisWorkbook '<~~ set to any open workbook or open a closed one
    wsn = "Agents"   '<~~ rename to the right master workbook

    'create the dictionary and
    Set dAGNTs = CreateObject("Scripting.Dictionary")
    dAGNTs.CompareMode = vbTextCompare

    'first the correct workbook
    With wb
        'work with the master worksheet
        With .Worksheets(wsn)
            'get all of the text values from column B
            vAGNTs = .Range(.Cells(6, "B"), .Cells(Rows.Count, "B").End(xlUp)).Value2

            'construct a dictionary of the agents usin unique keys
            For d = LBound(vAGNTs) To UBound(vAGNTs)
                'overwrite method - no check to see if it exists (just want unique list)
                dAGNTs.Item(vAGNTs(d, 1)) = vbNullString
            Next d

        End With

        'loop through the agents' individual worksheets
        'if one does not exist, create it from the master workbook
        For Each agnt In dAGNTs
            'set error control to catch non-existant agent worksheets
            On Error GoTo bm_Need_Agent_WS
            With Worksheets(agnt)
                On Error GoTo bm_Safe_Exit

                'if an agent worksheet did not exist then
                'one has been created with non-associated data removed
                'perform any additional operations here

                'example: today's date in A1
                .Cells(1, "A") = Date

            End With
        Next agnt

    End With

    'slip past agent worksheet creation
    GoTo bm_Safe_Exit

bm_Need_Agent_WS:
    'basic error control for bad worksheet names, etc.
    On Error GoTo 0
    'copy the master worksheet
    wb.Worksheets(wsn).Copy after:=Sheets(Sheets.Count)
    With wb.Worksheets(Sheets.Count)
        'rename the copy to the agent name
        .Name = StrConv(agnt, vbProperCase)
        'turn off any existing AutoFilter
        If .AutoFilterMode Then .AutoFilterMode = False
        'filter on column for everything that isn't the agent
        With .Range(.Cells(5, "B"), .Cells(Rows.Count, "B").End(xlUp))
            .AutoFilter field:=1, Criteria1:="<>" & agnt
            'step off the header row
            With .Resize(.Rows.Count - 1, 1).Offset(1, 0)
                'check if there is anything to remove
                If CBool(Application.Subtotal(103, .Cells)) Then
                    'delete all non-associated information
                    .EntireRow.Delete
                End If
            End With
        End With
        'turn off the AutoFilter we just created
        .AutoFilterMode = False
    End With
    'go back to the thrown error
    Resume

bm_Safe_Exit:
    'reset application environment
    appTGGL

End Sub

'helper sub to set/restore all of the environment settings
Public Sub appTGGL(Optional bTGGL As Boolean = True)
    With Application
        .ScreenUpdating = bTGGL
        .EnableEvents = bTGGL
        .DisplayAlerts = bTGGL
        .Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
        .CutCopyMode = False
        .StatusBar = vbNullString
    End With
    Debug.Print Timer
End Sub

选项显式
子代理工作表（）
Dim d为长，agnt为变体，vAGNTs为变体，dAGNTs为对象
将wsn设置为字符串，将wb设置为工作簿
设置特殊的应用环境
'appTGGL bTGGL:=False'调试完成后取消对此的注释
用@Jeeped great answer设置wb=thishworkbook'，我还将添加第二个答案。：-）

要将每个代理数据分离到单独的工作表，可以执行以下操作。。。
请参阅对代码的评论


因此，本质上，您只需要原始工作表（为每个代理重命名）的副本，其中所有与该代理无关的信息都被删除…？参考我的问题，我尝试了代码，但在每个工作表中，我都得到了第一行。
Option Explicit
Sub Move_Each_Agent_to_Sheet()
'   // Declare your Variables
    Dim Sht As Worksheet
    Dim Rng As Range
    Dim List As Collection
    Dim varValue As Variant
    Dim i As Long

'   // Set your Sheet name
    Set Sht = ActiveWorkbook.Sheets("Sheet1")

'   // set your auto-filter,  A6
    With Sht.Range("A6")
        .AutoFilter
    End With

'   // Set your agent Column range # (2) that you want to filter it
    Set Rng = Range(Sht.AutoFilter.Range.Columns(2).Address)

'   // Create a new Collection Object
    Set List = New Collection

'   // Fill Collection with Unique Values
    On Error Resume Next
    For i = 2 To Rng.Rows.Count
        List.Add Rng.Cells(i, 1), CStr(Rng.Cells(i, 1))
    Next i

'   // Start looping in through the collection Values
    For Each varValue In List
'       // Filter the Autofilter to macth the current Value
        Rng.AutoFilter Field:=2, Criteria1:=varValue

'       // Copy the AutoFiltered Range to new Workbook
        Sht.AutoFilter.Range.Copy
        Worksheets.Add.Paste
        ActiveSheet.Name = Left(varValue, 30)
        Cells.EntireColumn.AutoFit

'   // Loop back to get the next collection Value
    Next varValue

'   // Go back to main Sheet and removed filters
    Sht.AutoFilter.ShowAllData
    Sht.Activate
End Sub