Create a new sheet for each unique agent and move all the data to each sheet.

Question

I have this problem that I am trying to solve. every day I get a report containing the data that I need to send forward. Therefore, to make this a little easier, I 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 found one that would suggest doing pretty much that. But since this is not my area of ​​expertise, I cannot change it to process my request, and even make it work, probably. Does anyone have an 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, which I get an example

I keep getting the error in the line: a.Sort a (1, cl), 2, Header: = xlYes This I myself do not know what it does. Can anyone explain?

Answer 1

Here is a general model (highly commented) that should create sheets of your individual agents. This copies the original worksheet and deletes information that does not apply 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 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’s just easier for you to remove what you don’t need than to recreate many parts of where you started.

Answer 2

With a great @Jeep answer, I will also add a second answer. :-)

To divide the data of each agent into separate sheets, you can do the following ... see code comment

---

 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