为每个唯一代理创建一个新的 sheet，并将所有数据移动到每个 sheet
Create a new sheet for each unique agent and move all data to each sheet
我正试图解决这个问题。每天我都会收到一份包含我需要转发的数据的报告。因此，为了让它更容易一些，我试图找到一个宏，它使用代理的名称创建一个新的 sheet 并在创建的 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
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
这是我收到的报告示例
example
我不断在行上收到错误：a.Sort a(1, cl), 2, Header:=xlYes
我自己真的不知道它是做什么的。谁能解释一下？
这是一个通用模型（大量评论），应该可以生成您的个人代理工作表。这将复制原始 'master' 工作表并删除不属于每个代理的信息。
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
有时候，删除您不想要的内容比重新创建您开始时的许多部分更容易。
@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
我正试图解决这个问题。每天我都会收到一份包含我需要转发的数据的报告。因此，为了让它更容易一些，我试图找到一个宏，它使用代理的名称创建一个新的 sheet 并在创建的 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
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
这是我收到的报告示例 example
我不断在行上收到错误：a.Sort a(1, cl), 2, Header:=xlYes 我自己真的不知道它是做什么的。谁能解释一下？
这是一个通用模型（大量评论），应该可以生成您的个人代理工作表。这将复制原始 'master' 工作表并删除不属于每个代理的信息。
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
有时候，删除您不想要的内容比重新创建您开始时的许多部分更容易。
@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