您要遵循的逻辑似乎需要嵌套的For Each...Next Statement。
- 从列表中获取第一个（或下一个）Rep
- 在该代表上过滤 Raw_Data!B:B
- 在不更改 Rep 过滤器的情况下，为 C 列添加另一个过滤器（例如“热”）
- 将可见值转移到新的或现有的工作表中
- 在不更改 Rep 过滤器的情况下，将 C 列的过滤器更改为“Warm”，然后是“Lukewarm”，然后是“General”。每次更改后，将可见值转移到相应的工作表中。
- 从 C 列和 B 列中删除过滤器。
- 转到步骤 1。
模板工作表：
就接收数据而言，可以将结构良好但空白的工作表用作模板。我设想了四个具有工作表范围的命名范围；例如lst_Hot、lst_Warm、lst_Lukewarm 和 lst_General。这些可以通过连接"lst_" & filter_criteria 在您的代码中引用。它们指向的单元格（又名应用于：）最好使用公式动态引用。
'lst_Hot Applies to:
=Template!$A$4:INDEX(Template!$H:$H, MATCH("hot", Template!$A:$A, 0)+COUNTA(Template!$A$4:$A$5))
'lst_Warm Applies to:
=Template!$A$7:INDEX(Template!$H:$H, MATCH("warm", Template!$A:$A, 0)+COUNTA(Template!$A$7:$A$8))
'lst_Lukewarm Applies to:
=Template!$A$10:INDEX(Template!$H:$H, MATCH("lukewarm", Template!$A:$A, 0)+COUNTA(Template!$A$10:$A$11))
'lst_General Applies to:
=Template!$A$13:INDEX(Template!$H:$H, MATCH("general", Template!$A:$A, 0)+COUNTA(Template!$A$13:$A$14))
请注意，命名范围属于工作表范围，而不是更常见（和默认）的工作簿范围。这对于在新工作表中引用它们而不会混淆是必要的。
虽然 模板 工作表最初可能是可见的，但在首次使用后会以 xlSheetVeryHidden 隐藏。这意味着它不会在常规对话框中列出以取消隐藏工作表。您需要进入 VBE 并使用属性窗口（例如 F4）将 .Visible 属性设置为 XlSheetVisible 或在 VBE 的即时窗口中运行 Sheets("Template").Visible = xlSheetVisible（例如 Ctrl+G）。如果您不需要此级别的模板工作表隐藏，请更改使其成为 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(...)（可选）- 将 Rep 联系人列表拆分为单独的 XLSX 工作簿。可选择启动电子邮件发送。
- Sub emailRepContactLists(...)（可选）- 带有为 gmail 帐户配置的附件例程的电子邮件
- Sub scrub_clean(...) - 帮助 sub 删除所有 Rep 联系人列表工作表
- Sub appTGGL(...) - 辅助 sub 控制应用程序环境
结果：
运行main() 后，您应该会看到一个工作簿，其中填充了类似于以下内容的数字或代表联系人列表工作表：。
您可能需要考虑将 Orphid 响应中的类放入本节中的操作代码中。
目前，该示例工作簿可从我的公共保管箱Rep_Contact_List_Reports.xlsb 获得。