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

问题描述

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

我找到了一个假设可以做到这一点.但由于这不是我真正的专业领域，我无法修改它来处理我的请求，甚至可能使它工作.任何人有任何想法?

const cl&= 2Const datz&= 1Dim a As Variant, x As Worksheet, sh As WorksheetDim rws&、cls&、p&、i&、ri&、j&Dim u(), b As Boolean, yApplication.ScreenUpdating = False表格(Sheet1").激活rws = Cells.Find("*", , , , xlByRows, xlPrevious).Rowcls = Cells.Find("*", , , , xlByColumns, xlPrevious).ColumnSet x = Sheets.Add(After:=Sheets("Sheet1"))Sheets("Sheet1").Cells(1).Resize(rws, cls).Copy x.Cells(1)设置 a = x.Cells(1).Resize(rws, cls)a.Sort a(1, cl), 2, Header:=xlYesa = a.Resize(rws + 1)p = 2对于 i = p To rws + 1如果 a(i,cl)<>a(p, cl) 然后b = 错误对于工作表中的每个 shIf sh.Name = a(p, cl) Then b = True: Exit For下一个如果不是 b 那么Sheets.Add.Name = a(p, cl)带表(a(p, cl))x.Cells(1).Resize(, cls).Copy .Cells(1)ri = i - px.Cells(p, 1).Resize(ri, cls).Cut .Cells(2, 1).Cells(2, 1).Resize(ri, cls).Sort .Cells(2, datz), Header:=xlNoy = .Cells(datz).调整大小(ri + 1)ReDim u(1 到 2 * ri, 1 到 1)对于 j = 2 To riu(j, 1) = j如果 y(j, 1) <>y(j + 1, 1) 那么 u(j + ri, 1) = 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结束于万一p = i万一接下来我Application.DisplayAlerts = Falsex.删除Application.DisplayAlerts = TrueApplication.ScreenUpdating = True

这是我收到的报告示例

我在行上不断出错:a.Sort a(1, cl), 2, Header:=xlYes这本身我真的不知道它是做什么的.谁能解释一下?

解决方案

这里是一个通用模型(大量评论)，它应该生成您的个人代理工作表.这会复制原始主"工作表并删除与每个代理无关的信息.

Module1 代码

选项显式子代理工作表()Dim d As Long, agnt As Variant, vAGNTs As Variant, dAGNTs As Object将 wsn 调暗为字符串，将 wb 作为工作簿'设置特殊的应用环境'appTGGL bTGGL:=False '调试完成后取消注释Set wb = ThisWorkbook '<~~ 设置为任何打开的工作簿或打开一个关闭的工作簿wsn = "Agents" '<~~重命名为正确的主工作簿'创建字典并设置 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下一个结束于'遍历代理'个人工作表'如果一个不存在，从主工作簿创建它对于 dAGNT 中的每个 agnt'设置错误控制以捕获不存在的代理工作表出错时转到 bm_Need_Agent_WS带工作表(agnt)出错时转到 bm_Safe_Exit'如果代理工作表不存在则'一个已被创建并删除了非关联数据'在此处执行任何其他操作'示例:A1 中的今天日期.Cells(1, "A") = 日期结束于下一个代理结束于'滑过代理工作表的创建转到 bm_Safe_Exitbm_Need_Agent_WS:'坏工作表名称等的基本错误控制出错时转到 0'复制主工作表wb.Worksheets(wsn).Copy after:=Sheets(Sheets.Count)使用 wb.Worksheets(Sheets.Count)'将副本重命名为代理名称.Name = StrConv(agnt, vbProperCase)'关闭任何现有的自动过滤器如果 .AutoFilterMode 那么 .AutoFilterMode = False'过滤所有非代理的列随着 .Range(.Cells(5, "B"), .Cells(Rows.Count, "B").End(xlUp)).AutoFilter 字段:=1, Criteria1:="<>"&代理'离开标题行使用 .Resize(.Rows.Count - 1, 1).Offset(1, 0)'检查是否有要删除的东西如果 CBool​​(Application.Subtotal(103, .Cells)) 那么'删除所有非关联信息.EntireRow.Delete万一结束于结束于'关闭我们刚刚创建的自动过滤器.AutoFilterMode = False结束于'回到抛出的错误恢复bm_Safe_Exit:'重置应用环境应用TGGL结束子'辅助子设置/恢复所有环境设置公共子应用程序TGGL(可选bTGGL As Boolean = True)有申请.ScreenUpdating = bTGGL.EnableEvents = bTGGL.DisplayAlerts = bTGGL.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual).CutCopyMode = False.StatusBar = vbNullString结束于调试.打印定时器结束子

有时，删除不想要的东西比重新创建开始时的许多部分更容易.

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屋！