问题
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:
- Create a new worksheet for Rep
- Filter Raw data by Rep 1 & "Hot"
- Copy data into the new WS
- Filter raw data by Rep 1 & "Warm"
- Copy data into new Ws
- Repeat for each rating..
- Format in the template style
- Save this WS to a new workbook & save with reps name (from rep sheet?)
- 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.
回答1:
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.
回答2:
The logic you want to follow would seem to need a nested For Each...Next Statement.
- Get the first (or next) Rep from the list
- Filter Raw_Data!B:B on that Rep.
- Without altering the Rep filter, add another filter for column C (e.g. 'Hot')
- Transfer the visible values to a new or existing worksheet
- Without altering the Rep filter, change the filter for column C to 'Warm, then 'Lukewarm' then 'General. With each change, transfer the visible values to the appropriate worksheet.
- Remove the filter from column C and column B.
- Go to step 1.
Template Worksheet:
As far as receiving the data, a well-constructed but otherwise blank worksheet could be used as a template. I envision four named ranges with worksheet scope; e.g. lst_Hot, lst_Warm, lst_Lukewarm and lst_General. These can be referenced in your code by concatenating "lst_" & filter_criteria. The cells they point to (aka Applies to:) are best referenced dynamically with a formula.
'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))
Note that the named ranges are of Worksheet scope, not the more common (and default) Workbook scope. This is necessary to reference them in new worksheets without confusion.
While the Template worksheet may be initially visible, it will be hidden with
xlSheetVeryHiddenafter first use. This means it will not be listed in the conventional dialog to unhide a worksheet. You will need to go into the VBE and use the Properties window (e.g. F4) to set the .Visible property toXlSheetVisibleor runSheets("Template").Visible = xlSheetVisiblein the VBE's Immediate window (e.g. Ctrl+G). If you do not require this level of hiding the template worksheet, alter the code that makes it xlSheetVeryHidden.
Module1 (Code)
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() - run the operational procedures from here to take advantage of some options
- Sub generateRepContactLists(...) - This is the routine that performs the two nested filtering operations and value transfer to a copy of the Template worksheet.
- Sub distributeRepContactLists(...) (optional) - breaks the Rep contact lists to separate XLSX workbook. Optionally initiates the email send.
- Sub emailRepContactLists(...) (optional) - email with attachments routine configured for a gmail account
- Sub scrub_clean(...) - Helper sub to remove all Rep contact list worksheets
- Sub appTGGL(...) - Helper sub to control application environment
Results:
After running the main() you should be left with a workbook populated with a number or rep contact list worksheets that resemble the following:.
You may want to consider putting the classes from Orphid's response into the operational code found in this one.
For the time being, that sample workbook is available from my public dropbox at Rep_Contact_List_Reports.xlsb.
来源：https://stackoverflow.com/questions/31370531/excel-vba-splitting-data-into-report-table