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

我有这个问题,我试图解决。 每天我都会收到一份包含我需要发送的数据的报告。 所以为了使它更容易一点,我试图find一个macros,创build一个新的表与代理的名称,并移动在创build表中的每个代理的数据…

我find了一个可以做很多事情的人。 但是,由于这不是我的专业领域,所以我无法修改它来处理我的请求,甚至可能使其工作。 任何人有任何想法?

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 

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

在这里输入图像描述

我一直在行上发生错误:a.Sort a(1,cl),2,Header:= xlYes在我自己,我真的不知道它是什么。 谁能解释一下?

这是一个通用的模型(严重评论),应该产生你的个人代理工作表。 这复制了原来的“主”工作表,并删除了不属于每个代理人的信息。

Module1代码

 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 

有时候,删除你不想要的东西比重新创build你开始的许多部分要容易得多。

用@Jeeped很好的回答,我也会添加第二个答案。 🙂

要将每个代理数据分隔到单独的工作表,您可以执行以下操作…查看对代码的评论


 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