问题
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?
回答1:
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.
回答2:
With @Jeeped great answer, I will also add second answer. :-)
To separate each agent data to separate sheets you can do the following... see comment on the code
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
来源：https://stackoverflow.com/questions/36671453/create-a-new-sheet-for-each-unique-agent-and-move-all-data-to-each-sheet