vba - Excel VBA - 将数据拆分到报告表中

Question

我需要一些帮助来自动生成工作报告。

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

数据显示我们的销售代表潜在的新业务。该数据按销售代表以及新业务的评级(热、热情、不冷不热、一般)进行分割。

模板将每个代表的数据分成每个评级的单独表格(即在“代表 1”的工作表上，它将有四个表格，每个评级一个。这些表格将包含该评级的该代表的所有内容)。

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

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

下图显示了我的数据布局、代表表和我的表格模板文件。

我的数据:请注意，真实的数据集要大得多，我只是在这个例子中模拟了它。

代表列表:

输出模板:

我一直在思考它是如何工作的，到目前为止我有以下几点:

1. 为销售代表创建新工作表
2. 按第 1 次和“热门”过滤原始数据
3. 将数据复制到新的 WS
4. 按第 1 次和“温暖”过滤原始数据
5. 将数据复制到新的 W 中
6. 对每个评级重复此操作。
7. 采用模板样式的格式
8. 将此 WS 保存到新工作簿并使用代表姓名保存(来自代表表？)
9. 对代表表上的每个代表重复上述操作。

最终，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 上，但要按照特定的顺序，即热、温暖、不冷不热、一般(除前面列出的以外的所有内容)。如何确保在当前数据之后输入下一组过滤数据？

Edit2:我添加了一些辅助列，每个列都返回一个 true/false 来判断是否满足条件(热、暖、冷等)。

我正在尝试循环遍历过滤列表，单独复制每一行并将其放入模板文件的相关位置。

Answer 1

这有点长，但基本上我认为您应该将这些数据转换为稍后可以使用的连贯类(当您不可避免地需要扩展您的工具时)。这也使得它在概念上更容易处理。因此，我的类以您的数据集为模型，进入“类模块”，如下所示:

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

CR代表:

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

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

抱歉缺少评论 - 我打算稍后添加更多内容。