Excel VBA - 将数据拆分为报表 [英] Excel VBA - Splitting data into report table

问题描述

我有一个电子表格，其中包含数据转储，如下面的截图（这是一些数据我为这个例子嘲笑）。此电子表格还有另外两个工作表，一个有销售代表清单，另一个有我需要实现的基本模板。

这些数据显示了我们的潜在新业务销售代表。这个数据被销售代表分解，以及新业务的评级（热，温暖，温暖，一般）。

模板将每个代表数据分开在每个评级的单独表格中（即Rep 1表格），它将有四个表，每个评级一个表，这些表将包括该评级的代表的所有内容。）

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

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

以下图片显示了我的数据布局，我的表格模板文件。

我的数据：请注意真实的数据集大得多，我刚刚嘲笑这个例子。

代表列表：

输出模板：

我一直在想一下如何工作，到目前为止，我有以下：

1. 为Rep创建一个新的工作表


2. 通过Rep 1& Hot


3. 将数据复制到新的WS


4. 通过Rep 1& 温暖


5. 将数据复制到新的Ws


6. 为每个评级重复。


7. 模板样式


8. 将此WS保存到新的工作簿&保存与reps名称（从rep表？）


9. 对于每个代表在代码表上重复。

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

任何帮助都非常感谢。不幸的是，这有点在我头上。

编辑：

所以目前，我已经使用以下代码将我的原始数据分割到各个代码页：

  Sub SplitRep1（）
 
 ActiveWorkbook.Sheets（Raw_Data）。激活
 ActiveSheet.Range（$ A $ 1：$ J $ 20000）。AutoFilter字段：= 2，Criteria1：=Rep1关闭Helen Passelow数据
范围（A1）。选择
范围（Selection，Selection.End（xlDown））。选择'确保选择所有数据
范围（Selection，Selection.End （xlToRight））选择'确保选择所有数据
 Selection.Copy 
 ActiveWorkbook.Sheets（Rep1）。激活
范围（A1）。选择
 ActiveSheet选择
 ActiveSheet.Range（$ A $ 1：$ J $ 100000）AutoFilter字段：= 2'重置自动过滤器
范围（A1 ）。选择
 
 End Sub 
  

我已经为每个的销售代表我有&目前需要几秒钟才能运行。

下一部分是我卡住的地方。我有模板...我将数据移动到预格式化的模板或排序我的数据，然后添加格式？

我的想法现在将是过滤个人代表每次将数据复制到新的工作表上时，按热，暖，冷，冷等方式进行打印。

我想将它们粘贴到我的新WS上，但是按照一个特定的顺序，即热，温暖，温暖，通用（除上述以外的所有内容）。如何确保下一组过滤后的数据在当前输入之后输入？

Edit2：我添加了一些帮助列，每个返回一个true / false这个标准是否被打击（热，温暖，冷等）。

我试图循环筛选列表，单独复制每行将它放在我的模板文件的相关位置。

解决方案

这是一个很长的时间，但基本上我认为你应该转数据变成连贯的类，你可以稍后使用（当你不可避免地需要扩展你的工具）。它也使它在概念上更容易处理。所以，我的课程是建模在你的数据集上，进入课程模块，看起来像：

CCompany：

  Option Explicit 
 
私人pname As String 
私人pstatus As String 
私有价值作为货币
私人pdate为日期
私人pNextDate As日期
私人pnumber As String 
私人邮箱As String 
私人pcontact As String 
私人pcontacttitle As String 
 
 
公共属性获取名称（）As String 
 name = pname 
结束属性
 
公共属性获取状态（）As String 
 status = pstatus 
结束属性
 
公共属性获取值（）作为货币
值= pvalue 
结束属性
 
公共属性获取DateAdded（）作为日期
 ContactDate = pdate 
结束属性
 
公共属性获取NextContactDate（）作为日期
 NextContactDate = pNextDate 
结束属性
 
公共属性获取Number（）As String 
 Number = pnu mber 
结束属性
 
公共属性获取电子邮件（）As String 
 Email = pemail 
结束属性
 
公共属性Get Contact（）作为String 
联系人= pcontact 
结束属性
 
公共属性获取ContactTitle（）As String 
 ContactTitle = pcontacttitle 
结束属性
 
公共属性Let name（v As String）
 pname = v 
结束属性
 
公共属性让状态（v As String）
 pstatus = v 
结束属性
 
公共属性让值（v作为货币）
 pvalue = v 
结束属性
 
公共属性Let DateAdded（v As Date ）
 pdate = v 
结束属性
 
公共属性让NextContactDate（v As Date）
 pNextDate = v 
结束属性
 
公共属性Let Number（v As String）
 pnumber = v 
结束属性
 
公共属性让电子邮件（v As String）
 pemail = v 
结束属性
 
公共属性让联系人（v As S 
 pcontact = v 
结束属性
 
公共属性让ContactTitle（v As String）
 pcontacttitle = v 
结束属性
 
 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行，start_column + 4）.Value = pnumber 
 wsSheet.Cells（row，start_column + 5）.Value = pemail 
 wsSheet.Cells（row，start_column + 6）.Value = pvalue 
结束子
  

CRep：

 私人pname As String 
 
私人邮箱As String 
 
私人公司作为新集合
 
公共属性获取名称（）作为String 
 name = pname 
结束属性
 
公共属性获取电子邮件（）作为St ring 
电子邮件= pemail 
结束属性
 
 
公共属性Let name（v As String）
 pname = v 
结束属性
 
公共财产让电子邮件（v As String）
 pemail = v 
结束属性
 
公共功能AddCompany（公司作为CCompany）
 pcompanies。添加公司
结束函数
 
公共函数GetCompanyByName（name As String）
 Dim i As Long 
 
 For i = 0 To pcompanies.Count 
如果（pcompanies.Item（i）.name = name）然后
 GetCompany = pcompanies.Item（i）
退出函数
结束如果
下一个我
 
结束函数
 
公共函数GetCompanyByIndex（Index As Long）
 
 GetCompanyByIndex = pcompanies.Item（Index）
 
结束函数
 
公共属性Get CompanyCount（）As Long 
 CompanyCount = pcompanies.Count 
结束属性
 
公共功能RemoveCompany（Index As Long）
 pcompanies 。删除索引
结束函数
 
 P公共函数GetCompaniesByStatus（status As String）As Collection 
 Dim i As Long，col As New Collection 
 
 For i = 1 To pcompanies.Count 
如果pcompanies.Item（i） .status = status然后col.Add pcompanies.Item（i）
下一个i 
设置GetCompaniesByStatus = col 
结束函数
  

CReps（集合类）：

  Option Explicit 
私人reps As Collection 
 
私人子类Class_Initialize（）
设置reps =新集合
结束子
 
私有子类Class_Terminate（）
设置代表= Nothing 
 End Sub 
 
 Public Sub Add（obj As CRep）
 reps.Add obj 
 End Sub 
 
 Public Sub Remove索引作为变体）
 reps.Remove索引
 End Sub 
 
公共属性获取项目（索引为变体）作为CRep 
设置项目= reps.Item（索引） 
结束属性
 
属性获取Count（）As Long 
 Count = reps.Count 
结束属性
 
 Pu blic Sub Clear（）
 Set reps = New Collection 
 End Sub 
 
公共函数GetRep（name As String）As CRep 
 Dim i As Long 
 
对于i = 1 To reps.Count 
如果（reps.Item（i）.name = name）然后
设置GetRep = reps.Item（i）
退出函数
结束如果
下一步我
结束功能
  

我做了一个工作簿根据您的数据，然后添加以下代码模块：

  Option Explicit 
 
公共功能GetLastRow （ByRef wsSheet As Excel.Worksheet，ByVal列As Long）As Long 
 GetLastRow = wsSheet.Cells（wsSheet.Rows.Count，column）.End（xlUp）.row 
结束函数
 
公共函数GetReps（）As CReps 
 Dim x As Long，I As Long，col As New CReps，rep As CRep 
 
x = GetLastRow（Sheet2，1）
 
对于i = 2到x'忽略标题
设置rep =新CRep 
 rep.name = Sheet2.Cells（i，1）.Value Sheet2是我的代表列表中的工作表 - 我正在使用变量名称，因为它出现在属性窗口
 rep.Email = Sheet2.Cells（i，2）.Value 
 col.Add rep 
下一个i 
 
设置GetReps = col 
 
结束函数
 
 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 
设置rep = reps.GetRep（Sheet1.Cells（i，2）.Value）
如果不是IsNull（rep）然后
设置公司=新建公司
 company.name = Sheet1 .Cells（i，1）.Value'Sheet1是我把公司数据的地方
 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。单元格（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 
 
 
公共子写数据（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 
设置col = rep.GetCompaniesByStatus（Warm）
 write_col wsSheet，col，x，1 
 
x = x + col.Count + 2 
设置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，c olumn As Long）
 Dim i As Long，company As CCompany 
 For i = 1 To col.Count 
 Set company = col.Item（i）
 company.WriteRow wsSheet，行+（i  -  1），列
下一个i 
 End Sub 
  

和：

  Public Sub DoWork（）
 
 Dim reps As CReps，as As Long，wsSheet As Excel.Worksheet 
 
设置reps = GetReps 
 
 GetData reps 
 
对于i = 1 to reps.Count 
设置wsSheet = ThisWorkbook。 Sheets.Add（After：= ThisWorkbook.Sheets（ThisWorkbook.Sheets.Count））
 WriteData wsSheet，reps.Item（i）
下一个i 
 
 End Sub 
  

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

对不起，缺乏评论 - 我打算稍后添加。

I'm after a bit of help automating a report for work.

I have a spreadsheet with a data dump on, as per screenshot below (this is some data I have mocked up for this example). This spreadsheet also has two other worksheets, one has a list of sales reps, the other has the basic template I need to achieve.

The data shows potential new business for our sales reps. This data is split down by sales rep, as well as a rating for the new business (hot, warm, lukewarm, general).

The template splits each reps data up into a separate table for each rating (i.e on the sheet for "Rep 1", it will have four tables, one for each rating. These tables will include everything for that rep for that rating).

One thing to note is that the tables should be dynamic, i.e sometimes there will be 3 lines of data, sometimes 20.

Each sales rep has a worksheet of their own which will eventually get emailed to them.

The below images shows my data layout, the reps sheet & my table template file.

My Data: Please note the real data set is much larger, i've just mocked this up for this example.

Reps list:

Template for output:

I've been having a think about how itd work and so far I have the below:

1. Create a new worksheet for Rep
2. Filter Raw data by Rep 1 & "Hot"
3. Copy data into the new WS
4. Filter raw data by Rep 1 & "Warm"
5. Copy data into new Ws
6. Repeat for each rating..
7. Format in the template style
8. Save this WS to a new workbook & save with reps name (from rep sheet?)
9. Repeat for each rep on the rep sheet.

Eventually the VBA would have created a new workbook for each rep that I can then automate emailing.

Any help is much appreciated. Unfortunately this is a bit over my head at the moment.

Edit:

So at present, I have split my raw data onto the individual rep sheets using the code below:

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

I've replicated the above for each of the sales reps I have & it currently takes a couple of seconds to run.

The next part is where I get stuck. I have the template...Do I move my data into the preformatted template or sort my data then add the formatting?

My thoughts now would be to filter the individual rep sheet by Hot, Warm, Lukewarm, Cold etc, each time copying the data onto a new worksheet.

I would want to paste them onto my new WS, but in a specific order i.e Hot, Warm, Lukewarm, general (everything other than those listed previously). How would I ensure the next set of filtered data is entered after the current?

Edit2: I've added in some helper columns, each returns a true/false as to whether the criteria has been hit (hot, warm, cold etc).

I'm trying to loop through a filtered list, copying each line individually & placing it into the relevant place on my template file.

解决方案

This is a bit long, but basically I think you should turn that data into coherent classes you can use later (for when you inevitably need to extend your tool). It also makes it conceptually easier to deal with. So, my classes, modeled on your data sets, go in "class modules" and look like:

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 (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

I made a workbook based on your data, and then added the following code modules:

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

And:

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

So, basically I've made classes which encapsulate your data, added some macros for reading in data from a worksheet (it assumes you have headers in your tables, like your example), and one that dumps that data out to a specified worksheet (you'll need to add the correct formatting). That worksheet can be in any workbook you can write to. The final module is just a usage example, showing how to load in the data, and write it out to sheets in the same workbook. For larger datasets, you may want to avoid repeated writes to the workbook, and lift all the data up into an array before working on it.

Sorry for lack of comments - I intend to add more later.

这篇关于Excel VBA - 将数据拆分为报表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！