Excel VBA - 将数据拆分为报告 table
Excel VBA - Splitting data into report table
我在自动化工作报告方面需要一些帮助。
我有一个带有数据转储的传播sheet，如下面的屏幕截图所示（这是我为此示例模拟的一些数据）。这个传播sheet还有另外两个工作sheet，一个有销售代表名单，另一个有我需要实现的基本模板。
数据显示了我们销售代表的潜在新业务。此数据按销售代表以及新业务的评级（热、温、温、一般）拆分。
模板将每个代表数据拆分为每个评级的单独 table（即在 sheet 上 "Rep 1"，它将有四个 table，每个评级一个。这些 table 将包括该代表对该评级的所有内容）。
需要注意的是 table 应该是动态的，即有时会有 3 行数据，有时会有 20 行。
每个销售代表都有自己的作品sheet，最终会通过电子邮件发送给他们。
下图显示了我的数据布局、代表 sheet 和我的 table 模板文件。
我的数据：请注意真实的数据集要大得多，我只是为这个例子模拟了一下。
次数列表：
输出模板：
我一直在思考它是如何工作的，到目前为止我有以下内容：
- 为 Rep
创建新作品sheet
- 按 Rep 1 过滤原始数据 & "Hot"
- 将数据复制到新的 WS
- 按 Rep 1 过滤原始数据 & "Warm"
- 复制数据到新的Ws
- 对每个评分重复..
- 模板样式中的格式
- 将此 WS 保存到新工作簿并使用代表姓名保存（来自代表 sheet？）
- 对每个代表重复 sheet。
最终 VBA 会为每个代表创建一个新的工作簿，然后我可以自动发送电子邮件。
非常感谢任何帮助。不幸的是，这让我有点头疼。
编辑：
所以目前，我已经使用下面的代码将原始数据拆分到各个代表 sheet 中：
Sub SplitRep1()
ActiveWorkbook.Sheets("Raw_Data").Activate
ActiveSheet.Range("$A:$J000").AutoFilter Field:=2, Criteria1:="Rep1" 'Filters off Helen Passelow data
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select 'Ensures all data is selected
Range(Selection, Selection.End(xlToRight)).Select 'Ensures all data is selected
Selection.Copy
ActiveWorkbook.Sheets("Rep1").Activate
Range("A1").Select
ActiveSheet.Paste
Sheets("Raw_Data").Select
ActiveSheet.Range("$A:$J0000").AutoFilter Field:=2 'Resets autofilter
Range("A1").Select
End Sub
我已经为我的每个销售代表复制了上面的内容，目前需要几秒钟才能 运行。
下一部分是我卡住的地方。我有模板...我是将我的数据移动到预先格式化的模板中还是先对我的数据进行排序然后添加格式？
我现在的想法是通过热、暖、微温、冷等过滤个人代表sheet，每次将数据复制到新作品sheet。
我想将它们粘贴到我的新 WS 上，但要按特定顺序粘贴，即热、暖、微温、一般（除前面列出的以外的所有内容）。如何确保在当前数据之后输入下一组过滤数据？
Edit2：我添加了一些帮助列，每个 returns 一个 true/false 是否达到标准（热、暖、冷等）。
我正在尝试遍历过滤后的列表，分别复制每一行并将其放入模板文件的相关位置。
这有点长，但基本上我认为您应该将这些数据转化为连贯的 classes，您可以稍后使用（当您不可避免地需要扩展您的工具时）。这也使得它在概念上更容易处理。所以，我的 classes，以你的数据集为模型，进入 "class modules" 看起来像：
C公司：
Option Explicit
Private pname As String
Private pstatus As String
Private pvalue As Currency
Private pdate As Date
Private pNextDate As Date
Private pnumber As String
Private pemail As String
Private pcontact As String
Private pcontacttitle As String
Public Property Get name() As String
name = pname
End Property
Public Property Get status() As String
status = pstatus
End Property
Public Property Get Value() As Currency
Value = pvalue
End Property
Public Property Get DateAdded() As Date
ContactDate = pdate
End Property
Public Property Get NextContactDate() As Date
NextContactDate = pNextDate
End Property
Public Property Get Number() As String
Number = pnumber
End Property
Public Property Get Email() As String
Email = pemail
End Property
Public Property Get Contact() As String
Contact = pcontact
End Property
Public Property Get ContactTitle() As String
ContactTitle = pcontacttitle
End Property
Public Property Let name(v As String)
pname = v
End Property
Public Property Let status(v As String)
pstatus = v
End Property
Public Property Let Value(v As Currency)
pvalue = v
End Property
Public Property Let DateAdded(v As Date)
pdate = v
End Property
Public Property Let NextContactDate(v As Date)
pNextDate = v
End Property
Public Property Let Number(v As String)
pnumber = v
End Property
Public Property Let Email(v As String)
pemail = v
End Property
Public Property Let Contact(v As String)
pcontact = v
End Property
Public Property Let ContactTitle(v As String)
pcontacttitle = v
End Property
Public Sub WriteRow(ByRef wsSheet As Excel.Worksheet, row As Long, start_column As Long)
wsSheet.Cells(row, start_column).Value = pdate
wsSheet.Cells(row, start_column + 1).Value = pname
wsSheet.Cells(row, start_column + 2).Value = pcontact
wsSheet.Cells(row, start_column + 3).Value = pcontacttitle
wsSheet.Cells(row, start_column + 4).Value = pnumber
wsSheet.Cells(row, start_column + 5).Value = pemail
wsSheet.Cells(row, start_column + 6).Value = pvalue
End Sub
CRep:
Private pname As String
Private pemail As String
Private pcompanies As New Collection
Public Property Get name() As String
name = pname
End Property
Public Property Get Email() As String
Email = pemail
End Property
Public Property Let name(v As String)
pname = v
End Property
Public Property Let Email(v As String)
pemail = v
End Property
Public Function AddCompany(company As CCompany)
pcompanies.Add company
End Function
Public Function GetCompanyByName(name As String)
Dim i As Long
For i = 0 To pcompanies.Count
If (pcompanies.Item(i).name = name) Then
GetCompany = pcompanies.Item(i)
Exit Function
End If
Next i
End Function
Public Function GetCompanyByIndex(Index As Long)
GetCompanyByIndex = pcompanies.Item(Index)
End Function
Public Property Get CompanyCount() As Long
CompanyCount = pcompanies.Count
End Property
Public Function RemoveCompany(Index As Long)
pcompanies.Remove Index
End Function
Public Function GetCompaniesByStatus(status As String) As Collection
Dim i As Long, col As New Collection
For i = 1 To pcompanies.Count
If pcompanies.Item(i).status = status Then col.Add pcompanies.Item(i)
Next i
Set GetCompaniesByStatus = col
End Function
CReps (Collection class):
Option Explicit
Private reps As Collection
Private Sub Class_Initialize()
Set reps = New Collection
End Sub
Private Sub Class_Terminate()
Set reps = Nothing
End Sub
Public Sub Add(obj As CRep)
reps.Add obj
End Sub
Public Sub Remove(Index As Variant)
reps.Remove Index
End Sub
Public Property Get Item(Index As Variant) As CRep
Set Item = reps.Item(Index)
End Property
Property Get Count() As Long
Count = reps.Count
End Property
Public Sub Clear()
Set reps = New Collection
End Sub
Public Function GetRep(name As String) As CRep
Dim i As Long
For i = 1 To reps.Count
If (reps.Item(i).name = name) Then
Set GetRep = reps.Item(i)
Exit Function
End If
Next i
End Function
我根据你的数据做了一个工作簿，然后添加了以下代码模块：
Option Explicit
Public Function GetLastRow(ByRef wsSheet As Excel.Worksheet, ByVal column As Long) As Long
GetLastRow = wsSheet.Cells(wsSheet.Rows.Count, column).End(xlUp).row
End Function
Public Function GetReps() As CReps
Dim x As Long, i As Long, col As New CReps, rep As CRep
x = GetLastRow(Sheet2, 1)
For i = 2 To x 'ignore headers
Set rep = New CRep
rep.name = Sheet2.Cells(i, 1).Value 'Sheet2 is the sheet with my rep list in - I'm using the variable name, as it appears in the properties window
rep.Email = Sheet2.Cells(i, 2).Value
col.Add rep
Next i
Set GetReps = col
End Function
Public Sub GetData(ByRef reps As CReps)
Dim x As Long, i As Long, rep As CRep, company As CCompany
x = GetLastRow(Sheet1, 1)
For i = 2 To x
Set rep = reps.GetRep(Sheet1.Cells(i, 2).Value)
If Not IsNull(rep) Then
Set company = New CCompany
company.name = Sheet1.Cells(i, 1).Value 'Sheet1 is where I put my company data
company.status = Sheet1.Cells(i, 3).Value
company.Value = Sheet1.Cells(i, 4).Value
company.DateAdded = Sheet1.Cells(i, 5).Value
company.NextContactDate = Sheet1.Cells(i, 6).Value
company.Number = Sheet1.Cells(i, 7).Value
company.Email = Sheet1.Cells(i, 8).Value
company.Contact = Sheet1.Cells(i, 9).Value
company.ContactTitle = Sheet1.Cells(i, 10).Value
rep.AddCompany company
End If
Next i
End Sub
Public Sub WriteData(ByRef wsSheet As Excel.Worksheet, ByRef rep As CRep)
Dim x As Long, col As Collection
x = 2
Set col = rep.GetCompaniesByStatus("Hot")
write_col wsSheet, col, x, 1
x = x + col.Count + 2
Set col = rep.GetCompaniesByStatus("Warm")
write_col wsSheet, col, x, 1
x = x + col.Count + 2
Set col = rep.GetCompaniesByStatus("Lukewarm")
write_col wsSheet, col, x, 1
x = x + col.Count + 2
Set col = rep.GetCompaniesByStatus("General")
write_col wsSheet, col, x, 1
End Sub
Private Sub write_col(ByRef wsSheet As Excel.Worksheet, col As Collection, row As Long, column As Long)
Dim i As Long, company As CCompany
For i = 1 To col.Count
Set company = col.Item(i)
company.WriteRow wsSheet, row + (i - 1), column
Next i
End Sub
并且：
Public Sub DoWork()
Dim reps As CReps, i As Long, wsSheet As Excel.Worksheet
Set reps = GetReps
GetData reps
For i = 1 To reps.Count
Set wsSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
WriteData wsSheet, reps.Item(i)
Next i
End Sub
所以，基本上我做了 classes 来封装你的数据，添加了一些宏来从工作表中读取数据（它假设你的表中有 headers，就像你的例子)，以及将数据转储到指定工作表的一个（您需要添加正确的格式）。该工作表可以在您可以写入的任何工作簿中。最后一个模块只是一个使用示例，展示了如何加载数据，并将其写入同一工作簿中的工作表。对于较大的数据集，您可能希望避免重复写入工作簿，并在处理之前将所有数据提升到一个数组中。
抱歉缺少评论 - 我打算稍后添加更多。
您要遵循的逻辑似乎需要嵌套 For Each...Next Statement。
- 从列表中获取第一个（或下一个）代表
- 过滤 Raw_Data!B:B 在那个 Rep.
- 在不更改 Rep 过滤器的情况下，为 C 列添加另一个过滤器（例如 'Hot'）
- 将可见值转移到新的或现有的工作表
- 在不改变 Rep 过滤器的情况下，将 C 列的过滤器更改为“温暖”，然后 'Lukewarm' 然后是“一般”。每次更改后，将可见值传输到相应的工作表。
- 删除 C 列和 B 列的过滤器。
- 转到步骤 1。
模板工作表：
就接收数据而言，可以使用结构良好但空白的工作表作为模板。我设想了四个具有工作表范围的命名范围；例如lst_Hot、lst_Warm、lst_Lukewarm 和 lst_General。这些可以通过连接 "lst_" & filter_criteria 在您的代码中引用。它们指向的单元格（又名适用于：）最好使用公式动态引用。
'lst_Hot Applies to:
=Template!$A:INDEX(Template!$H:$H, MATCH("hot", Template!$A:$A, 0)+COUNTA(Template!$A:$A))
'lst_Warm Applies to:
=Template!$A:INDEX(Template!$H:$H, MATCH("warm", Template!$A:$A, 0)+COUNTA(Template!$A:$A))
'lst_Lukewarm Applies to:
=Template!$A:INDEX(Template!$H:$H, MATCH("lukewarm", Template!$A:$A, 0)+COUNTA(Template!$A:$A))
'lst_General Applies to:
=Template!$A:INDEX(Template!$H:$H, MATCH("general", Template!$A:$A, 0)+COUNTA(Template!$A:$A))
请注意，命名范围属于 Worksheet 范围，而不是更常见（和默认）的 Workbook 范围。这对于在新工作表中引用它们而不造成混淆是必要的。
While the Template worksheet may be initially visible, it will be hidden with xlSheetVeryHidden after first use. This means it will not be listed in the conventional dialog to unhide a worksheet. You will need to go into the VBE and use the Properties window (e.g. F4) to set the .Visible property to XlSheetVisible or run Sheets("Template").Visible = xlSheetVisible in the VBE's Immediate window (e.g. Ctrl+G). If you do not require this level of hiding the template worksheet, alter the code that makes it xlSheetVeryHidden.
模块 1（代码）
Option Explicit
Sub main()
'use bRESETALL:=True to delete the Rep worksheets before creating new ones
'Call generateRepContactLists(bRESETALL:=True)
'use bRESETALL:=False to apppend data to the existing Rep worksheets or create new ones if they do not exist
Call generateRepContactLists(bRESETALL:=False)
'optional mailing routine - constructs separate XLSX workbooks and sends them
'this routine expects a full compliment of worksheet tabs and valid email addresses
'Call distributeRepContactLists(bSENDASATTACH:=True)
End Sub
Sub generateRepContactLists(Optional bRESETALL As Boolean = False)
Dim f As Long, r As Long, rs As Long, v As Long, col As Long
Dim wsr_rws As Long, wsr_col As Long, fldREP As Long, fldSTS As Long
Dim vSTSs As Variant, vREPs As Variant
Dim wsrd As Worksheet, wsr As Worksheet, wst As Worksheet, wb As Workbook
On Error GoTo bm_Safe_Exit
appTGGL bTGGL:=False
If bRESETALL Then
Do While Worksheets.Count > 3: Worksheets(4).Delete: Loop
End If
Set wb = ThisWorkbook
Set wsrd = wb.Sheets("Raw_Data")
Set wst = wb.Sheets("Template")
vREPs = wb.Sheets("Reps").Range("lst_Reps")
'need to go through these next ones backwards due to named range row assignment
vSTSs = Array("General", "Lukewarm", "Warm", "Hot")
With wsrd
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
fldREP = Application.Match("rep", .Rows(1), 0)
fldSTS = Application.Match("status", .Rows(1), 0)
For r = LBound(vREPs) To UBound(vREPs)
.AutoFilter field:=fldREP, Criteria1:=vREPs(r, 1)
For v = LBound(vSTSs) To UBound(vSTSs)
.AutoFilter field:=fldSTS, Criteria1:=vSTSs(v)
With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
If CBool(Application.Subtotal(103, .Columns(fldSTS))) Then
rs = Application.Subtotal(103, .Columns(fldSTS))
On Error GoTo bm_Missing_Rep_Ws
Set wsr = Worksheets(vREPs(r, 1))
On Error GoTo bm_Safe_Exit
With wsr.Range("lst_" & vSTSs(v))
wsr_rws = .Rows.Count
.Offset(wsr_rws, 0).Resize(rs, .Columns.Count).Insert _
Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
End With
For col = 1 To .Columns.Count
If CBool(Application.CountIf(wsr.Range("lst_" & vSTSs(v)).Rows(1), .Rows(0).Cells(1, col).Value2)) Then
wsr_col = Application.Match(.Rows(0).Cells(1, col).Value2, wsr.Range("lst_" & vSTSs(v)).Rows(1), 0)
.Columns(col).Copy _
Destination:=wsr.Range("lst_" & vSTSs(v)).Cells(1, wsr_col).Offset(wsr_rws, 0)
wsr.Range("lst_" & vSTSs(v)).Cells(1, 1).Offset(wsr_rws, 0).Resize(rs, 1) = Date
End If
Next col
With wsr.Range("lst_" & vSTSs(v))
.Cells.Sort Key1:=.Columns(8), Order1:=xlDescending, _
Key2:=.Columns(7), Order2:=xlDescending, _
Orientation:=xlTopToBottom, Header:=xlYes
.Parent.Tab.Color = .Rows(0).Cells(1).Interior.Color
End With
Set wsr = Nothing
End If
End With
.AutoFilter field:=fldSTS
Next v
.AutoFilter field:=fldREP
Next r
End With
If .AutoFilterMode Then .AutoFilterMode = False
.Activate
End With
GoTo bm_Safe_Exit
bm_Missing_Rep_Ws:
If Err.Number = 9 Then
With wst
.Visible = xlSheetVisible
.Copy after:=Sheets(Sheets.Count)
.Visible = xlSheetVeryHidden
End With
With Sheets(Sheets.Count)
.Name = vREPs(r, 1)
.Cells(1, 1) = vREPs(r, 1)
End With
Resume
End If
bm_Safe_Exit:
appTGGL
End Sub
Sub distributeRepContactLists(Optional bSENDASATTACH As Boolean = True)
Dim rw As Long, w As Long, fn As String
On Error GoTo bm_Safe_Exit
appTGGL bTGGL:=False
With Worksheets("Reps").Range("lst_Reps")
For rw = 1 To .Rows.Count
fn = .Cells(rw, 1).Value2 & " Contact List " & Format(Date, "yyyy mm dd\.\x\l\s\x")
fn = Replace(fn, Chr(32), Chr(95))
fn = Environ("TEMP") & Chr(92) & fn
If CBool(Len(Dir(fn))) Then Kill fn
For w = 4 To Worksheets.Count
If LCase(Worksheets(w).Name) = LCase(.Cells(rw, 1).Value2) Then Exit For
Next w
If w <= Worksheets.Count Then
With Worksheets(.Cells(rw, 1).Value2)
.Copy
ActiveWorkbook.SaveAs Filename:=fn, FileFormat:=xlOpenXMLWorkbook
ActiveWindow.Close False
End With
If bSENDASATTACH Then
Call emailRepContactLists(sEML:=.Cells(rw, 2).Value2, sATTCH:=fn)
.Cells(rw, 3) = Now
End If
End If
Next rw
End With
bm_Safe_Exit:
appTGGL
End Sub
Sub emailRepContactLists(sEML As String, sATTCH As String)
Dim sFROM As String, sFROMPWD As String, cdoMail As New CDO.Message
sFROM = "your_email@gmail.com"
sFROMPWD = "your_gmail_password"
On Error GoTo bm_ErrorOut
With cdoMail
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = sFROM
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = sFROMPWD
.Configuration.Fields.Update
.From = sFROM
.To = sEML
.CC = ""
.BCC = ""
.Subject = Format(Date, "\N\e\w\ \C\o\n\t\a\c\t\ \L\i\s\t\ \f\o\r\ dd-mmm-yyyy")
.HTMLBody = "<html><body><p>Please find attached the new contact listings.</p></body></html>"
.AddAttachment sATTCH
.send
End With
GoTo bm_FallOut
bm_ErrorOut:
Debug.Print "could not send eml to " & sEML
bm_FallOut:
Set cdoMail = Nothing
End Sub
Sub scrub_clean(Optional wb As Workbook)
appTGGL bTGGL:=False
If wb Is Nothing Then Set wb = ThisWorkbook
Do While Worksheets.Count > 3: Worksheets(4).Delete: Loop
appTGGL
End Sub
Sub appTGGL(Optional bTGGL As Boolean = True)
Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
Application.EnableEvents = bTGGL
Application.DisplayAlerts = bTGGL
Application.ScreenUpdating = bTGGL
Application.Cursor = IIf(bTGGL, xlDefault, xlWait)
End Sub
- Sub main() - 运行运行程序从这里开始利用一些选项
- Sub generateRepContactLists(...) - 这是执行两个嵌套过滤操作并将值传输到模板工作表副本的例程。
- Sub distributeRepContactLists(...)（可选）- 将代表联系人列表拆分为单独的 XLSX 工作簿。可选择启动电子邮件发送。
- Sub emailRepContactLists(...)（可选）- 为 gmail 帐户配置的带有附件例程的电子邮件
- Sub scrub_clean(...) - Helper sub 删除所有 Rep 联系人列表工作表
- Sub appTGGL(...) - Helper sub 控制应用程序环境
结果：
在 运行 完成 main() 之后，您应该留下一个工作簿，其中填充了类似于以下内容的数字或代表联系人列表工作表：.
您可能需要考虑将 Orphid 的响应中的 类 放入本文中找到的操作代码中。
目前，该示例工作簿可从我的 public 投递箱中获得，地址为 Rep_Contact_List_Reports.xlsb。
我在自动化工作报告方面需要一些帮助。
我有一个带有数据转储的传播sheet，如下面的屏幕截图所示（这是我为此示例模拟的一些数据）。这个传播sheet还有另外两个工作sheet，一个有销售代表名单，另一个有我需要实现的基本模板。
数据显示了我们销售代表的潜在新业务。此数据按销售代表以及新业务的评级（热、温、温、一般）拆分。
模板将每个代表数据拆分为每个评级的单独 table（即在 sheet 上 "Rep 1"，它将有四个 table，每个评级一个。这些 table 将包括该代表对该评级的所有内容）。
需要注意的是 table 应该是动态的，即有时会有 3 行数据，有时会有 20 行。
每个销售代表都有自己的作品sheet，最终会通过电子邮件发送给他们。
下图显示了我的数据布局、代表 sheet 和我的 table 模板文件。
我的数据：请注意真实的数据集要大得多，我只是为这个例子模拟了一下。
次数列表：
输出模板：
我一直在思考它是如何工作的，到目前为止我有以下内容：
- 为 Rep 创建新作品sheet
- 按 Rep 1 过滤原始数据 & "Hot"
- 将数据复制到新的 WS
- 按 Rep 1 过滤原始数据 & "Warm"
- 复制数据到新的Ws
- 对每个评分重复..
- 模板样式中的格式
- 将此 WS 保存到新工作簿并使用代表姓名保存（来自代表 sheet？）
- 对每个代表重复 sheet。
最终 VBA 会为每个代表创建一个新的工作簿，然后我可以自动发送电子邮件。
非常感谢任何帮助。不幸的是，这让我有点头疼。
编辑：
所以目前，我已经使用下面的代码将原始数据拆分到各个代表 sheet 中：
Sub SplitRep1()
ActiveWorkbook.Sheets("Raw_Data").Activate
ActiveSheet.Range("$A:$J000").AutoFilter Field:=2, Criteria1:="Rep1" 'Filters off Helen Passelow data
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select 'Ensures all data is selected
Range(Selection, Selection.End(xlToRight)).Select 'Ensures all data is selected
Selection.Copy
ActiveWorkbook.Sheets("Rep1").Activate
Range("A1").Select
ActiveSheet.Paste
Sheets("Raw_Data").Select
ActiveSheet.Range("$A:$J0000").AutoFilter Field:=2 'Resets autofilter
Range("A1").Select
End Sub
我已经为我的每个销售代表复制了上面的内容，目前需要几秒钟才能 运行。
下一部分是我卡住的地方。我有模板...我是将我的数据移动到预先格式化的模板中还是先对我的数据进行排序然后添加格式？
我现在的想法是通过热、暖、微温、冷等过滤个人代表sheet，每次将数据复制到新作品sheet。
我想将它们粘贴到我的新 WS 上，但要按特定顺序粘贴，即热、暖、微温、一般（除前面列出的以外的所有内容）。如何确保在当前数据之后输入下一组过滤数据？
Edit2：我添加了一些帮助列，每个 returns 一个 true/false 是否达到标准（热、暖、冷等）。
我正在尝试遍历过滤后的列表，分别复制每一行并将其放入模板文件的相关位置。
这有点长，但基本上我认为您应该将这些数据转化为连贯的 classes，您可以稍后使用（当您不可避免地需要扩展您的工具时）。这也使得它在概念上更容易处理。所以，我的 classes，以你的数据集为模型，进入 "class modules" 看起来像：
C公司：
Option Explicit
Private pname As String
Private pstatus As String
Private pvalue As Currency
Private pdate As Date
Private pNextDate As Date
Private pnumber As String
Private pemail As String
Private pcontact As String
Private pcontacttitle As String
Public Property Get name() As String
name = pname
End Property
Public Property Get status() As String
status = pstatus
End Property
Public Property Get Value() As Currency
Value = pvalue
End Property
Public Property Get DateAdded() As Date
ContactDate = pdate
End Property
Public Property Get NextContactDate() As Date
NextContactDate = pNextDate
End Property
Public Property Get Number() As String
Number = pnumber
End Property
Public Property Get Email() As String
Email = pemail
End Property
Public Property Get Contact() As String
Contact = pcontact
End Property
Public Property Get ContactTitle() As String
ContactTitle = pcontacttitle
End Property
Public Property Let name(v As String)
pname = v
End Property
Public Property Let status(v As String)
pstatus = v
End Property
Public Property Let Value(v As Currency)
pvalue = v
End Property
Public Property Let DateAdded(v As Date)
pdate = v
End Property
Public Property Let NextContactDate(v As Date)
pNextDate = v
End Property
Public Property Let Number(v As String)
pnumber = v
End Property
Public Property Let Email(v As String)
pemail = v
End Property
Public Property Let Contact(v As String)
pcontact = v
End Property
Public Property Let ContactTitle(v As String)
pcontacttitle = v
End Property
Public Sub WriteRow(ByRef wsSheet As Excel.Worksheet, row As Long, start_column As Long)
wsSheet.Cells(row, start_column).Value = pdate
wsSheet.Cells(row, start_column + 1).Value = pname
wsSheet.Cells(row, start_column + 2).Value = pcontact
wsSheet.Cells(row, start_column + 3).Value = pcontacttitle
wsSheet.Cells(row, start_column + 4).Value = pnumber
wsSheet.Cells(row, start_column + 5).Value = pemail
wsSheet.Cells(row, start_column + 6).Value = pvalue
End Sub
CRep:
Private pname As String
Private pemail As String
Private pcompanies As New Collection
Public Property Get name() As String
name = pname
End Property
Public Property Get Email() As String
Email = pemail
End Property
Public Property Let name(v As String)
pname = v
End Property
Public Property Let Email(v As String)
pemail = v
End Property
Public Function AddCompany(company As CCompany)
pcompanies.Add company
End Function
Public Function GetCompanyByName(name As String)
Dim i As Long
For i = 0 To pcompanies.Count
If (pcompanies.Item(i).name = name) Then
GetCompany = pcompanies.Item(i)
Exit Function
End If
Next i
End Function
Public Function GetCompanyByIndex(Index As Long)
GetCompanyByIndex = pcompanies.Item(Index)
End Function
Public Property Get CompanyCount() As Long
CompanyCount = pcompanies.Count
End Property
Public Function RemoveCompany(Index As Long)
pcompanies.Remove Index
End Function
Public Function GetCompaniesByStatus(status As String) As Collection
Dim i As Long, col As New Collection
For i = 1 To pcompanies.Count
If pcompanies.Item(i).status = status Then col.Add pcompanies.Item(i)
Next i
Set GetCompaniesByStatus = col
End Function
CReps (Collection class):
Option Explicit
Private reps As Collection
Private Sub Class_Initialize()
Set reps = New Collection
End Sub
Private Sub Class_Terminate()
Set reps = Nothing
End Sub
Public Sub Add(obj As CRep)
reps.Add obj
End Sub
Public Sub Remove(Index As Variant)
reps.Remove Index
End Sub
Public Property Get Item(Index As Variant) As CRep
Set Item = reps.Item(Index)
End Property
Property Get Count() As Long
Count = reps.Count
End Property
Public Sub Clear()
Set reps = New Collection
End Sub
Public Function GetRep(name As String) As CRep
Dim i As Long
For i = 1 To reps.Count
If (reps.Item(i).name = name) Then
Set GetRep = reps.Item(i)
Exit Function
End If
Next i
End Function
我根据你的数据做了一个工作簿，然后添加了以下代码模块：
Option Explicit
Public Function GetLastRow(ByRef wsSheet As Excel.Worksheet, ByVal column As Long) As Long
GetLastRow = wsSheet.Cells(wsSheet.Rows.Count, column).End(xlUp).row
End Function
Public Function GetReps() As CReps
Dim x As Long, i As Long, col As New CReps, rep As CRep
x = GetLastRow(Sheet2, 1)
For i = 2 To x 'ignore headers
Set rep = New CRep
rep.name = Sheet2.Cells(i, 1).Value 'Sheet2 is the sheet with my rep list in - I'm using the variable name, as it appears in the properties window
rep.Email = Sheet2.Cells(i, 2).Value
col.Add rep
Next i
Set GetReps = col
End Function
Public Sub GetData(ByRef reps As CReps)
Dim x As Long, i As Long, rep As CRep, company As CCompany
x = GetLastRow(Sheet1, 1)
For i = 2 To x
Set rep = reps.GetRep(Sheet1.Cells(i, 2).Value)
If Not IsNull(rep) Then
Set company = New CCompany
company.name = Sheet1.Cells(i, 1).Value 'Sheet1 is where I put my company data
company.status = Sheet1.Cells(i, 3).Value
company.Value = Sheet1.Cells(i, 4).Value
company.DateAdded = Sheet1.Cells(i, 5).Value
company.NextContactDate = Sheet1.Cells(i, 6).Value
company.Number = Sheet1.Cells(i, 7).Value
company.Email = Sheet1.Cells(i, 8).Value
company.Contact = Sheet1.Cells(i, 9).Value
company.ContactTitle = Sheet1.Cells(i, 10).Value
rep.AddCompany company
End If
Next i
End Sub
Public Sub WriteData(ByRef wsSheet As Excel.Worksheet, ByRef rep As CRep)
Dim x As Long, col As Collection
x = 2
Set col = rep.GetCompaniesByStatus("Hot")
write_col wsSheet, col, x, 1
x = x + col.Count + 2
Set col = rep.GetCompaniesByStatus("Warm")
write_col wsSheet, col, x, 1
x = x + col.Count + 2
Set col = rep.GetCompaniesByStatus("Lukewarm")
write_col wsSheet, col, x, 1
x = x + col.Count + 2
Set col = rep.GetCompaniesByStatus("General")
write_col wsSheet, col, x, 1
End Sub
Private Sub write_col(ByRef wsSheet As Excel.Worksheet, col As Collection, row As Long, column As Long)
Dim i As Long, company As CCompany
For i = 1 To col.Count
Set company = col.Item(i)
company.WriteRow wsSheet, row + (i - 1), column
Next i
End Sub
并且：
Public Sub DoWork()
Dim reps As CReps, i As Long, wsSheet As Excel.Worksheet
Set reps = GetReps
GetData reps
For i = 1 To reps.Count
Set wsSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
WriteData wsSheet, reps.Item(i)
Next i
End Sub
所以，基本上我做了 classes 来封装你的数据，添加了一些宏来从工作表中读取数据（它假设你的表中有 headers，就像你的例子)，以及将数据转储到指定工作表的一个（您需要添加正确的格式）。该工作表可以在您可以写入的任何工作簿中。最后一个模块只是一个使用示例，展示了如何加载数据，并将其写入同一工作簿中的工作表。对于较大的数据集，您可能希望避免重复写入工作簿，并在处理之前将所有数据提升到一个数组中。
抱歉缺少评论 - 我打算稍后添加更多。
您要遵循的逻辑似乎需要嵌套 For Each...Next Statement。
- 从列表中获取第一个（或下一个）代表
- 过滤 Raw_Data!B:B 在那个 Rep.
- 在不更改 Rep 过滤器的情况下，为 C 列添加另一个过滤器（例如 'Hot'）
- 将可见值转移到新的或现有的工作表
- 在不改变 Rep 过滤器的情况下，将 C 列的过滤器更改为“温暖”，然后 'Lukewarm' 然后是“一般”。每次更改后，将可见值传输到相应的工作表。
- 删除 C 列和 B 列的过滤器。
- 转到步骤 1。
模板工作表：
就接收数据而言，可以使用结构良好但空白的工作表作为模板。我设想了四个具有工作表范围的命名范围；例如lst_Hot、lst_Warm、lst_Lukewarm 和 lst_General。这些可以通过连接 "lst_" & filter_criteria 在您的代码中引用。它们指向的单元格（又名适用于：）最好使用公式动态引用。
'lst_Hot Applies to:
=Template!$A:INDEX(Template!$H:$H, MATCH("hot", Template!$A:$A, 0)+COUNTA(Template!$A:$A))
'lst_Warm Applies to:
=Template!$A:INDEX(Template!$H:$H, MATCH("warm", Template!$A:$A, 0)+COUNTA(Template!$A:$A))
'lst_Lukewarm Applies to:
=Template!$A:INDEX(Template!$H:$H, MATCH("lukewarm", Template!$A:$A, 0)+COUNTA(Template!$A:$A))
'lst_General Applies to:
=Template!$A:INDEX(Template!$H:$H, MATCH("general", Template!$A:$A, 0)+COUNTA(Template!$A:$A))
请注意，命名范围属于 Worksheet 范围，而不是更常见（和默认）的 Workbook 范围。这对于在新工作表中引用它们而不造成混淆是必要的。
While the Template worksheet may be initially visible, it will be hidden with
xlSheetVeryHiddenafter first use. This means it will not be listed in the conventional dialog to unhide a worksheet. You will need to go into the VBE and use the Properties window (e.g. F4) to set the .Visible property toXlSheetVisibleor runSheets("Template").Visible = xlSheetVisiblein the VBE's Immediate window (e.g. Ctrl+G). If you do not require this level of hiding the template worksheet, alter the code that makes it xlSheetVeryHidden.
模块 1（代码）
Option Explicit
Sub main()
'use bRESETALL:=True to delete the Rep worksheets before creating new ones
'Call generateRepContactLists(bRESETALL:=True)
'use bRESETALL:=False to apppend data to the existing Rep worksheets or create new ones if they do not exist
Call generateRepContactLists(bRESETALL:=False)
'optional mailing routine - constructs separate XLSX workbooks and sends them
'this routine expects a full compliment of worksheet tabs and valid email addresses
'Call distributeRepContactLists(bSENDASATTACH:=True)
End Sub
Sub generateRepContactLists(Optional bRESETALL As Boolean = False)
Dim f As Long, r As Long, rs As Long, v As Long, col As Long
Dim wsr_rws As Long, wsr_col As Long, fldREP As Long, fldSTS As Long
Dim vSTSs As Variant, vREPs As Variant
Dim wsrd As Worksheet, wsr As Worksheet, wst As Worksheet, wb As Workbook
On Error GoTo bm_Safe_Exit
appTGGL bTGGL:=False
If bRESETALL Then
Do While Worksheets.Count > 3: Worksheets(4).Delete: Loop
End If
Set wb = ThisWorkbook
Set wsrd = wb.Sheets("Raw_Data")
Set wst = wb.Sheets("Template")
vREPs = wb.Sheets("Reps").Range("lst_Reps")
'need to go through these next ones backwards due to named range row assignment
vSTSs = Array("General", "Lukewarm", "Warm", "Hot")
With wsrd
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
fldREP = Application.Match("rep", .Rows(1), 0)
fldSTS = Application.Match("status", .Rows(1), 0)
For r = LBound(vREPs) To UBound(vREPs)
.AutoFilter field:=fldREP, Criteria1:=vREPs(r, 1)
For v = LBound(vSTSs) To UBound(vSTSs)
.AutoFilter field:=fldSTS, Criteria1:=vSTSs(v)
With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
If CBool(Application.Subtotal(103, .Columns(fldSTS))) Then
rs = Application.Subtotal(103, .Columns(fldSTS))
On Error GoTo bm_Missing_Rep_Ws
Set wsr = Worksheets(vREPs(r, 1))
On Error GoTo bm_Safe_Exit
With wsr.Range("lst_" & vSTSs(v))
wsr_rws = .Rows.Count
.Offset(wsr_rws, 0).Resize(rs, .Columns.Count).Insert _
Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
End With
For col = 1 To .Columns.Count
If CBool(Application.CountIf(wsr.Range("lst_" & vSTSs(v)).Rows(1), .Rows(0).Cells(1, col).Value2)) Then
wsr_col = Application.Match(.Rows(0).Cells(1, col).Value2, wsr.Range("lst_" & vSTSs(v)).Rows(1), 0)
.Columns(col).Copy _
Destination:=wsr.Range("lst_" & vSTSs(v)).Cells(1, wsr_col).Offset(wsr_rws, 0)
wsr.Range("lst_" & vSTSs(v)).Cells(1, 1).Offset(wsr_rws, 0).Resize(rs, 1) = Date
End If
Next col
With wsr.Range("lst_" & vSTSs(v))
.Cells.Sort Key1:=.Columns(8), Order1:=xlDescending, _
Key2:=.Columns(7), Order2:=xlDescending, _
Orientation:=xlTopToBottom, Header:=xlYes
.Parent.Tab.Color = .Rows(0).Cells(1).Interior.Color
End With
Set wsr = Nothing
End If
End With
.AutoFilter field:=fldSTS
Next v
.AutoFilter field:=fldREP
Next r
End With
If .AutoFilterMode Then .AutoFilterMode = False
.Activate
End With
GoTo bm_Safe_Exit
bm_Missing_Rep_Ws:
If Err.Number = 9 Then
With wst
.Visible = xlSheetVisible
.Copy after:=Sheets(Sheets.Count)
.Visible = xlSheetVeryHidden
End With
With Sheets(Sheets.Count)
.Name = vREPs(r, 1)
.Cells(1, 1) = vREPs(r, 1)
End With
Resume
End If
bm_Safe_Exit:
appTGGL
End Sub
Sub distributeRepContactLists(Optional bSENDASATTACH As Boolean = True)
Dim rw As Long, w As Long, fn As String
On Error GoTo bm_Safe_Exit
appTGGL bTGGL:=False
With Worksheets("Reps").Range("lst_Reps")
For rw = 1 To .Rows.Count
fn = .Cells(rw, 1).Value2 & " Contact List " & Format(Date, "yyyy mm dd\.\x\l\s\x")
fn = Replace(fn, Chr(32), Chr(95))
fn = Environ("TEMP") & Chr(92) & fn
If CBool(Len(Dir(fn))) Then Kill fn
For w = 4 To Worksheets.Count
If LCase(Worksheets(w).Name) = LCase(.Cells(rw, 1).Value2) Then Exit For
Next w
If w <= Worksheets.Count Then
With Worksheets(.Cells(rw, 1).Value2)
.Copy
ActiveWorkbook.SaveAs Filename:=fn, FileFormat:=xlOpenXMLWorkbook
ActiveWindow.Close False
End With
If bSENDASATTACH Then
Call emailRepContactLists(sEML:=.Cells(rw, 2).Value2, sATTCH:=fn)
.Cells(rw, 3) = Now
End If
End If
Next rw
End With
bm_Safe_Exit:
appTGGL
End Sub
Sub emailRepContactLists(sEML As String, sATTCH As String)
Dim sFROM As String, sFROMPWD As String, cdoMail As New CDO.Message
sFROM = "your_email@gmail.com"
sFROMPWD = "your_gmail_password"
On Error GoTo bm_ErrorOut
With cdoMail
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = sFROM
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = sFROMPWD
.Configuration.Fields.Update
.From = sFROM
.To = sEML
.CC = ""
.BCC = ""
.Subject = Format(Date, "\N\e\w\ \C\o\n\t\a\c\t\ \L\i\s\t\ \f\o\r\ dd-mmm-yyyy")
.HTMLBody = "<html><body><p>Please find attached the new contact listings.</p></body></html>"
.AddAttachment sATTCH
.send
End With
GoTo bm_FallOut
bm_ErrorOut:
Debug.Print "could not send eml to " & sEML
bm_FallOut:
Set cdoMail = Nothing
End Sub
Sub scrub_clean(Optional wb As Workbook)
appTGGL bTGGL:=False
If wb Is Nothing Then Set wb = ThisWorkbook
Do While Worksheets.Count > 3: Worksheets(4).Delete: Loop
appTGGL
End Sub
Sub appTGGL(Optional bTGGL As Boolean = True)
Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
Application.EnableEvents = bTGGL
Application.DisplayAlerts = bTGGL
Application.ScreenUpdating = bTGGL
Application.Cursor = IIf(bTGGL, xlDefault, xlWait)
End Sub
- Sub main() - 运行运行程序从这里开始利用一些选项
- Sub generateRepContactLists(...) - 这是执行两个嵌套过滤操作并将值传输到模板工作表副本的例程。
- Sub distributeRepContactLists(...)（可选）- 将代表联系人列表拆分为单独的 XLSX 工作簿。可选择启动电子邮件发送。
- Sub emailRepContactLists(...)（可选）- 为 gmail 帐户配置的带有附件例程的电子邮件
- Sub scrub_clean(...) - Helper sub 删除所有 Rep 联系人列表工作表
- Sub appTGGL(...) - Helper sub 控制应用程序环境
结果：
在 运行 完成 main() 之后，您应该留下一个工作簿，其中填充了类似于以下内容的数字或代表联系人列表工作表：.
您可能需要考虑将 Orphid 的响应中的 类 放入本文中找到的操作代码中。
目前，该示例工作簿可从我的 public 投递箱中获得，地址为 Rep_Contact_List_Reports.xlsb。