Excel VBA - Splitting data into report table

Question

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

Answer 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.

Answer 2

The logic you want to follow would seem to need a nested For Each...Next Statement.

1. Get the first (or next) Rep from the list
2. Filter Raw_Data!B:B on that Rep.
3. Without altering the Rep filter, add another filter for column C (e.g. 'Hot')
4. Transfer the visible values to a new or existing worksheet
5. 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.
6. Remove the filter from column C and column B.
7. 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 xlSheetVeryHidden after 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 to XlSheetVisible or run Sheets("Template").Visible = xlSheetVisible in 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.