为每个独特代理创建一个新的工作表，并将所有数据移动到每个工作表 [英] Create a new sheet for each unique agent and move all data to each sheet

问题描述

我有这个问题，我正在努力解决。每天我收到一份包含我需要发送的数据的报告。所以为了使它更容易一点，我试图找到一个宏创建一个新的工作表与代理的名称，并移动每个代理的数据在创建的工作表...

我发现一个假设做得很多。但是，由于这不是我的专业领域，所以我无法修改它来处理我的请求，甚至使它可以工作。任何人都有想法？

  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 
表格（Sheet1）。激活
 rws = Cells.Find（ *，，，，xlByRows，xlPrevious）.Row 
 cls = Cells.Find（*，，，，xlByColumns，xlPrevious）.Column 
 
 Set x = Sheets.Add之后：= Sheets（Sheet1））
表格（Sheet1）。单元格（1）.Resize（rws，cls）.Copy x.Cells（1）
设置a = x.Cells （1）.Resize（rws，cls）
 a.Sort a（1，cl），2，Header：= xlYes 
a = a.Resize（rws + 1）
p = 2 
 
对于i = p到rws + 1 
如果a（i，cl） a（p，cl）然后
b = False 
对于每个sh在工作表
如果sh.Name = a（p，cl）然后b = True：退出对于
下一个
如果不是b然后
 Sheets.Add.Name = a（p，cl）
带表格（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到2 * ri，1到1）
对于j = 2对于ri 
u（j，1）= j 
如果y（j，1） y（j + 1，1）然后u（j + ri，1）= j 
下一个j 
 .Cells（cls + 1）.Resize（2 * ri）= u 
。单元格（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 
  

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

我不断收到错误：a.Sort a（ 1，cl），2，标题：= xlYes
在自我中我不知道它是做什么的。有人可以解释吗

解决方案

这是一个通用模型（大量评论），应该生成您的个人代理工作表。这将复制原始主工作表，并删除与每个代理不相关的信息。

Module1 code

  Option Explicit 
 
子代理工作表（）
 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调试完成后
设置wb = ThisWorkbook'< ~~设置为任何打开的工作簿或打开一个关闭的
 wsn =代理'< ~~重命名为正确的主工作簿
 
'创建字典和
设置dAGNTs = CreateObject（Scripting.Dictionary）
 dAGNTs.CompareMode = vbTextCompare 
 
 '第一个正确的工作簿
与wb 
'工作与主工作表
与.Worksheets（wsn）
'从列B中获取所有文本值
 vAGNTs = .Range（.Cells（6，B），.Cells（Rows.Count，B）。End（xlUp））。Value2 
 
'键
对于d = LBound（vAGNTs）到UBound（vAGNTs）
'覆盖方法 - 不检查它是否存在（只需要唯一的列表）
 dAGNTs.Item（vAGNTs（d， 1））= vbNullString 
下一步d 
 
结束
 
'循环通过代理的个人工作表
'如果不存在，创建它从主工作簿
对于每个agnt在dAGNTs 
'设置错误控制捕获不存在的代理工作表
错误GoTo bm_Need_Agent_WS 
与工作表（agnt）
开Ë rror GoTo bm_Safe_Exit 
 
'如果代理工作表不存在然后
'已创建与非关联数据删除
'执行任何其他操作
 
'示例：今天的日期在A1 
 .Cells（1，A）=日期
 
结束
下一步agnt 
 
结束
 
'滑过代理工作表创建
 GoTo bm_Safe_Exit 
 
 bm_Need_Agent_WS：
'糟糕的工作表名称的基本错误控制等
 On Error GoTo 0 
'复制主工作表
 wb.Worksheets（wsn）.Copy after：= Sheets（Sheets.Count）
带有wb.Worksheets（Sheets.Count）
'将副本重命名为代理名称
 .Name = StrConv（agnt，vbProperCase）
'关闭任何现有的AutoFilter 
如果.AutoFilterMode然后.AutoFilterMode = False 
'过滤器在列上一切不是代理
带有.Range（.Cells（5，B），.Cells（Rows.Count，B）。End（xlUp））
 .AutoFilter字段： = 1，Criteria1：= -  &安培; agnt 
'标题行
用.Resize（.Rows.Count  -  1，1）.Offset（1，0）
'检查是否有任何要删除
如果CBool​​（Application.Subtotal（103，.Cells））然后
'删除所有非关联信息
 .EntireRow.Delete 
 End If 
 End With 
结束
'关闭AutoFilter我们刚刚创建
 .AutoFilterMode = False 
结束
'回到抛出的错误
恢复
 
 bm_Safe_Exit：
'重置应用程序环境
 appTGGL 
 
 End Sub 
 
'助手子设置/恢复所有环境设置
 Public Sub appTGGL（可选bTGGL As Boolean = True）
应用程序
 .ScreenUpdating = bTGGL 
 .EnableEvents = bTGGL 
 .DisplayAlerts = bTGGL 
 .Calculation = IIf （bTGGL， xlCalculationAutomatic，xlCalculationManual）
 .CutCopyMode = False 
 .StatusBar = vbNullString 
 End with 
 Debug.Print Timer 
 End Sub 
  

有时，删除不想要的东西更容易，而不是重新创建您所开始的许多部分。

I have this issue that I'm trying to solve. each day I get an report containing data that I need to send forward. So in order to make it a bit easier I have tried to find a macro that creates a new sheet with the name of the agent and moves the data for each agent in the created sheet...

I have found one that suppose to do pretty much that. But since this isn't really my area of expertise I'm not able to modify it to handle my request, and even make it work probably. Anyone have any idea ?

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

This is an example of my report I receive example

I keep getting error on row: a.Sort a(1, cl), 2, Header:=xlYes That in self i don't really know what it does. Can anyone explain?

解决方案

Here is a generic model (heavily commented) that should produce your individual agent worksheets. This copies the original 'master' worksheet and removes information that does not pertain to each individual agent.

Module1 code

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

Sometimes it is just easier to remove what you do not want than recreate many parts of what you started with.

这篇关于为每个独特代理创建一个新的工作表，并将所有数据移动到每个工作表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！