Question

我在帮助自动生成工作报告之后得到了一些帮助。

我有一个带有数据转储的电子表格，如下面的屏幕截图所示（这是我为此示例模拟的一些数据）。此电子表格还有两个其他工作表，一个包含销售代表列表，另一个包含我需要实现的基本模板。

数据显示我们的销售代表可能有新的业务。这些数据按销售代表分类，以及新业务的评级（热门，热门，不冷不热，一般）。

模板将每个代表数据分成一个单独的表格，用于每个评级（即在＃34; Rep 1和＃34;的表格中，它将有四个表，每个评级一个。这些表格将包含所有内容该评级的代表。）

有一点需要注意的是，表格应该是动态的，即有时会有3行数据，有时甚至是20行。

每位销售代表都有自己的工作表，最终会通过电子邮件发送给他们。

下面的图片显示了我的数据布局，代表表＆amp;我的表模板文件。

我的数据：请注意，实际数据集要大得多，我只是嘲笑了这个例子。 DataImage

代表名单： RepsList

输出模板： TemplateOutput

我一直在思考它是如何工作的，到目前为止，我有以下内容：

为Rep
按Rep 1＆amp ;;过滤原始数据＆＃34;热＆＃34;
将数据复制到新WS
按Rep 1＆amp ;;过滤原始数据＆＃34;暖＆＃34;
将数据复制到新的Ws
对每个评级重复..
模板样式中的格式
将此WS保存到新工作簿＆amp;使用代表名称保存（来自代表？）
对代表页上的每个代表重复。

最终，VBA会为每个代表创建一个新的工作簿，然后我可以自动发送电子邮件。

非常感谢任何帮助。不幸的是，目前这有点过头了。

修改

所以目前，我已使用以下代码将原始数据拆分到各个代表纸上：

Sub SplitRep1()

    ActiveWorkbook.Sheets("Raw_Data").Activate
    ActiveSheet.Range("$A$1:$J$20000").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$1:$J$100000").AutoFilter Field:=2 'Resets autofilter
    Range("A1").Select

End Sub

我已经为我所拥有的每位销售代表复制了上述内容。它目前需要几秒钟才能运行。

下一部分是我被困的地方。我有模板...我是否将数据移动到预先格式化的模板中或对数据进行排序然后添加格式？

我现在的想法是每次将数据复制到新的工作表上时，按热，暖，温，冷等过滤单个代表。

我想将它们粘贴到我的新WS上，但是按照特定的顺序，即Hot，Warm，Lukewarm，general（除了之前列出的那些之外的所有内容）。如何确保在当前？

Edit2：我已经添加了一些帮助列，每个都返回一个关于标准是否被命中的真/假（热，冷，冷等）。

我试图遍历已过滤的列表，单独复制每一行＆amp;将其放入我的模板文件的相关位置。

Answer 1

这有点长，但基本上我认为你应该把这些数据变成你以后可以使用的连贯类（当你不可避免地需要扩展你的工具时）。它还使概念上更容易处理。因此，我的类以数据集为模型，进入“类模块”，看起来像：

CCompany：

 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（收集类）：

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

所以，基本上我已经创建了封装数据的类，添加了一些用于从工作表中读取数据的宏（它假设你的表中有标题，就像你的例子一样），还有一个将数据转储到a指定的工作表（您需要添加正确的格式）。该工作表可以在您可以写入的任何工作簿中。最后一个模块只是一个用法示例，展示了如何加载数据，并将其写入同一工作簿中的工作表。对于较大的数据集，您可能希望避免重复写入工作簿，并在处理之前将所有数据提升到数组中。

很抱歉没有评论 - 我打算稍后再添加。

Answer 2

您想要遵循的逻辑似乎需要嵌套的For Each...Next Statement。

从列表中获取第一个（或下一个）Rep
过滤Raw_Data！B：B上的Rep。
在不更改Rep过滤器的情况下，为C列添加另一个过滤器（例如“Hot”）
将可见值传输到新的或现有的工作表
在不改变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))

Template for Rep Contact reports

请注意，命名范围是工作表范围，而不是更常见（和默认）的工作簿范围。这对于在新工作表中引用它们而不会产生混淆是必要的。

虽然模板工作表最初可见，但首次使用后会隐藏xlSheetVeryHidden。这意味着它不会在常规对话框中列出以取消隐藏工作表。您需要进入VBE并使用“属性”窗口（例如F4）将.Visible属性设置为XlSheetVisible或在VBE的立即窗口中运行Sheets("Template").Visible = xlSheetVisible（例如Ctrl + G）。如果您不需要此级别隐藏模板工作表，请更改使其成为xlSheetVeryHidden的代码。

Module1（代码）

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（...） - Helper sub删除所有Rep联系人列表工作表
Sub appTGGL（...） - Helper sub来控制应用程序环境

<强>结果：

运行main()后，您应该留下一个工作簿，其中包含类似于以下内容的数字或代表联系人列表工作表：。

Rep Contact listing results

您可能需要考虑将Orphid响应中的类放入此中的操作代码中。

目前，该示例工作簿可在Rep_Contact_List_Reports.xlsb的公共保管箱中找到。

Excel VBA - 将数据拆分为报表

2 个答案: