Excel VBA – 将数据分解到报表中

我经过一些自动化工作报告的帮助。

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

这些数据显示了我们销售代表潜在的新业务。 这些数据是由销售代表，以及对新业务的评价（热，温，温，一般）。

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

有一件事要注意，表格应该是dynamic的，即有时会有3行数据，有时候是20行。

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

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

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

代表清单：

输出模板：

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

1. 为Rep创build一个新的工作表
2. 通过Rep 1和“Hot”过滤原始数据
3. 将数据复制到新的WS中
4. 通过Rep 1过滤原始数据＆“Warm”
5. 将数据复制到新的W中
6. 重复每个评级..
7. 格式在模板样式
8. 保存这个WS到一个新的工作簿和保存代表姓名（从表单？）
9. 重复每个代表在表单上的代表。

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

任何帮助深表感谢。 不幸的是，目前我的头脑还是有些过头了。

编辑：

所以目前，我已经使用下面的代码将我的原始数据分解到各个代表单上：

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 

我已经复制了以上每个销售代表我有＆它目前需要几秒钟跑。

接下来的部分是我卡住的地方。 我有模板…我移动我的数据到预先格式化的模板或sorting我的数据，然后添加格式？

我现在的想法是每次将数据复制到一个新的工作表上，以过滤Hot，Warm，Lukewarm，Cold等单独的表单。

我想将它们粘贴到我的新WS上，但是要按照特定的顺序，即热，温，冷，一般（除了之前列出的以外）。 如何确保在当前之后input下一组过滤的数据？

编辑2：我已经添加了一些帮助列，每个返回一个真/假的标准是否已被击中（热，温暖，寒冷等）。

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

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（集合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 

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

抱歉缺乏评论 – 我打算以后再添加。

Answer 2

你想遵循的逻辑似乎需要一个嵌套的For Each … Next语句 。

1. 从列表中获取第一个（或下一个）代表
2. 过滤Raw_Data！B：B在该Rep。
3. 在不改变Repfilter的情况下，为列C添加另一个filter（例如“Hot”）
4. 将可见值传输到新的或现有的工作表
5. 在不改变Repfilter的情况下，将列C的filter更改为“Warm”，然后是“Lukewarm”，然后是“General”。 每次更改时，将可见值传送到相应的工作表。
6. 从列C和列B中删除filter。
7. 转到第1步。

模板工作表：

就接收到的数据而言，一个结构良好但空白的工作表可以用作模板。 我设想了四个带有工作表范围的命名范围; 例如lst_Hot，lst_Warm，lst_Lukewarm和lst_General。 这些可以通过连接"lst_" & filter_criteria在代码中引用。 他们指向的单元格（又名应用:)最好是用公式dynamic引用的。

 '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的立即窗口（例如Ctrl + G）中运行Sheets("Template").Visible = xlSheetVisible 。 如果您不需要隐藏模板工作表的这个级别，请修改使其成为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 = "[e-mail]" 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工作簿。 可select启动电子邮件发送。
• Sub emailRepContactLists（…）（可选） – 为gmail帐户configuration附件例程的电子邮件
• Sub scrub_clean（…） – Helper sub删除所有Rep联系人列表工作表
• Sub appTGGL（…） – Helper sub来控制应用程序环境

结果：

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

你可能要考虑把来自Orphid的响应的类放入这个操作代码中。

目前，该示例工作簿可从我的公共收件箱Rep_Contact_List_Reports.xlsb中获得 。