Sorting/Consolidating data using VBA -----------------------------------------Second Attempt-----------Please help----------------

[sssb2000]

Hi everyone,
thanks for looking.

i have the above raw data.......i'm trying to get to the output shown below using VBA. There is about 1600 rows of data in my raw data set and they need to be consolidated into the output table shown below.

there needs to be four of these output tables, one for each quarter.......ie. quarter one is jan. 1 to March 31, etc.


Your help is very much appreciated.

RAW Data:

Excel 2010
	A	N	O	P	Q	R	S	T
1	xxx	Max	Location	Title	Status	Start Date/Time	End Date/Time	xxx
2	*********	30	A	Course #mpkek234	CANCELLED	12/3/2012 8:00	12/3/2012 12:00	*********
3	*********	20	A	Course #mpkek234	ENROLLED	12/3/2012 8:00	12/3/2012 12:00	*********
4	*********	40	B	Course #mpkek234	ENROLLED	12/5/2012 8:00	12/6/2012 12:00	*********
5	*********	40	B	Course #mpkek234	ENROLLED	12/5/2012 8:00	12/6/2012 12:00	*********
6	*********	40	B	Course #mpkek234	CANCELLED	12/5/2012 8:00	12/6/2012 12:00	*********
7	*********	40	C	course 4k5jj3	CANCELLED	11/5/2012 8:00	11/9/2012 17:00	*********
8	*********	40	C	course 4k5jj3	CANCELLED	11/5/2012 8:00	11/9/2012 17:00	*********
9	*********	40	C	course 4k5jj3	ENROLLED	11/5/2012 8:00	11/9/2012 17:00	*********
10	*********	40	C	course 4k5jj3	WAITLIST	11/5/2012 8:00	11/9/2012 17:00	*********
11	*********	25	D	Course kk3kj	WAITLIST	3/12/2013 9:00	3/14/2013 18:00	*********
12	*********	25	D	Course kk3kj	WAITLIST	3/12/2013 9:00	3/14/2013 18:00	*********
13	*********	21	E	Course kk3kj	ENROLLED	11/6/2012 9:00	11/8/2012 18:00	*********
14	*********	21	E	Course kk3kj	ENROLLED	11/6/2012 9:00	11/8/2012 18:00	*********
15	*********	21	E	Course kk3kj	ENROLLED	11/6/2012 9:00	11/8/2012 18:00	*********
16	*********	21	E	Course kk3kj	CANCELLED	11/6/2012 9:00	11/8/2012 18:00	*********
report(3)

Output:

Excel 2010
	A	B	C	D	E	F	G	H	I	J	K	L
2	Course Number	Loc	Start Date	End date	Max	Total Reg	Cancel	Waitlist	Currently Enrolled	No Show	Walk-in	Final Participants
3	Course #mpkek234	A	12/3/2012	12/3/2012	30	2	1	0	1	0	0	1
4	Course #mpkek234	B	12/5/2012	12/6/2012	20	3	1	0	2	0	0	2
5	course 4k5jj3	C	11/5/2012	11/9/2012	40	4	2	1	1	0	0	1
6	Course kk3kj	D	10/18/2012	10/19/2012	40	2	0	2	0	0	0	0
7	Course kk3kj	E	3/12/2013	3/14/2013	25	4	1	0	3	0	0	3
Q1 FY13

 

[Leith Ross]

Hello sssb2000,

That error tells me your version of Office is not 2007 or 2010. What version are you using?

 

[Leith Ross]

Hello sssb2000,

The file you posted seems to be an 95 - 2003 version of Excel. However, when I try to open it Excel tells me there is problem with the file format. Did you change the file extension?

 

[sssb2000]

oops. you're right.
I'm at home now and thought i have 2007 but no, i have 2002. good call.
i'll try it first thing in the am at work.

by the way, did you get a chance to take a look at the file i posted in page 1? Could you please take a look and see if the code does all the 'rules' i listed in the "Raw" page?
thank you again and again!

Hello sssb2000,

That error tells me your version of Office is not 2007 or 2010. What version are you using?

 

[sssb2000]

No, the file has an .xlsx extension. i made it at work using my MS office 2010
i can still open it using my excel 2002 though.....strange....

Hello sssb2000,

The file you posted seems to be an 95 - 2003 version of Excel. However, when I try to open it Excel tells me there is problem with the file format. Did you change the file extension?

 

[Leith Ross]

Hello sssb2000,

I was able to open the file on my other computer that has Office 2003. It has a file converter to read Files in 2007 format. However, it will not read on my 2010 computer.

I will need to make some changes to the macro to work the way you descibed. Shouldn't take to much time to do.

 

[sssb2000]

I'm glad it worked.
thanks very much. I'll standby.

Hello sssb2000,

I was able to open the file on my other computer that has Office 2003. It has a file converter to read Files in 2007 format. However, it will not read on my 2010 computer.

I will need to make some changes to the macro to work the way you descibed. Shouldn't take to much time to do.

 

[sssb2000]

Hello sssb2000,

I will need to make some changes to the macro to work the way you descibed. Shouldn't take to much time to do.

Please let me know if there's any additional information that can help with this.
thanks!!!

 

[Leith Ross]

Hello sssb2000,

I had to make some major changes to macro and that of course led to new problems. I have tested the macro thoroughly using the data you provided but the real test will be on the database itself. There were some issues with the status like "WaitList" and "WaitListed". Those have been corrected. The "Pending" status is now counted as "Enrolled". Try this out on your database and let me know what happens. Here is the link to the workbook and the macro code.

Link to the Workbook...
Data Consolidation ver 2.xlsm

' http://www.mrexcel.com/forum/excel-questions/682241-sorting-consolidating-data-using-visual-basic-applications-second-attempt-please-help.html
' Written: January 30, 2013 for sssb2000
' Updated: January 31, 2013 - Added Buttons to each quarterly sheet that will create a report based on the dates the user selects.
' Author:  Leith Ross

Public RawDataPrepped As Boolean
Public RawDataRng As Range

Sub PrepRawData()

    Dim Cell As Range
    Dim Header As Variant
    Dim Wks As Worksheet
    
        Set Wks = Worksheets("Raw")
        
        Wks.AutoFilterMode = False
        Wks.Sort.SortFields.Clear
        
        For Each Header In Array("Start Date/Time", "End Date/Time")
            Set Cell = Wks.UsedRange.Find(Header, , xlValues, xlWhole, xlByRows, xlNext, False, False, False)
            If Not Cell Is Nothing Then
                Cell = Left(Cell, Len(Cell) - 5)
                Cell.EntireColumn.NumberFormat = "m/d/yyyy"
                Cell.EntireColumn.AutoFit
            End If
        Next Header
        
        Set RawDataRng = Wks.Range("N1:S1")
        Set RngEnd = Wks.Cells(Rows.Count, RawDataRng.Column).End(xlUp)
        If RngEnd.Row < RawDataRng.Row Then Exit Sub Else Set RawDataRng = RawDataRng.Resize(RowSize:=RngEnd.Row - RawDataRng.Row + 1)
        
      ' Sort the Raw data by location and date.
        RawDataRng.Sort _
            Key1:=RawDataRng.Cells(1, 3), Order1:=xlAscending, _
            Key2:=RawDataRng.Cells(1, 6), Order2:=xlAscending, _
            Header:=xlYes, MatchCase:=False, _
            Orientation:=xlTopToBottom, _
            DataOption1:=xlSortTextAsNumbers, _
            DataOption2:=xlSortTextAsNumbers
        
        Wks.Sort.Apply
        
        RawDataPrepped = True
        
End Sub

Sub CreateReport()

    Dim Course As String
    Dim Data As Variant
    Dim DataRng As Range
    Dim Dict As Object
    Dim EndDate As Date
    Dim Location As Variant
    Dim Qfilter As Integer
    Dim r As Long
    Dim Rng As Range
    Dim rngArea As Range
    Dim RngEnd As Range
    Dim StartDate As Date
    Dim Status As String
    Dim Wks As Worksheet
    Dim wksReport As Worksheet
    
        Set Wks = Worksheets("Raw")
        Set wksReport = ActiveSheet
        
        If Not RawDataPrepped Then Call PrepRawData
        
        If RawDataRng Is Nothing Then
            MsgBox "There is No Raw Data Available.", vbExclamation
            Exit Sub
        End If
        
        Application.ScreenUpdating = False
               
          ' Filter the data using the Start and End Dates.
            If wksReport.Range("B2") = "" Or wksReport.Range("C2") = "" Then
                MsgBox "Please fill in the Start and End dates.", vbExclamation
                Exit Sub
            End If
            
                StartDate = wksReport.Range("B2")
                EndDate = wksReport.Range("C2")
                
              ' Modify the data for filtering.
                wksReport.Range("B2") = ">=" & StartDate
                wksReport.Range("C2") = "<=" & EndDate
            
              ' Filter the data. The Criteria range must be a Named Range!
                If Wks.FilterMode Then Wks.ShowAllData
                RawDataRng.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range(wksReport.Name & "_Criteria")
                
              ' Restore the dates as they were.
                wksReport.Range("B2") = StartDate
                wksReport.Range("C2") = EndDate
        
              ' Get the filtered cells less the header row.
                Set DataRng = RawDataRng.SpecialCells(xlCellTypeVisible)
                Set DataRng = Intersect(DataRng, Wks.Range("N2", "S" & Rows.Count))
                
              ' Exit if there is no filtered data.
                If DataRng Is Nothing Then
                    wksReport.UsedRange.Offset(1, 0).ClearContents
                    wksReport.Activate
                    Application.ScreenUpdating = True
                    Exit Sub
                End If
            
                ReDim Data(11)
                
                  ' Start consolidating the data.
              
                    Set Dict = CreateObject("Scripting.Dictionary")
                    Dict.CompareMode = vbTextCompare
                
                    For Each rngArea In DataRng.Areas
                        For Each Cell In rngArea.Columns(4).Cells
                            Status = UCase(Trim(Cell))
                    
                            If Status <> "" Then
                                Location = Cell.Offset(0, -2) & Cell.Offset(0, 1)
                        
                                If Not Dict.Exists(Location) Then
                                    ReDim Data(11)
                                    Data(0) = Cell.Offset(0, -1).Value  ' Course
                                    Data(1) = Cell.Offset(0, -2).Value  ' Location
                                    Data(2) = Cell.Offset(0, 1).Value   ' Start Date
                                    Data(3) = Cell.Offset(0, 2).Value   ' End Date
                                    Data(4) = Cell.Offset(0, -3).Value  ' Max Registration
                                    Data(8) = 0                         ' Currently Enrolled
                                    Dict.Add Location, Data
                                End If
                        
                                Data = Dict(Location)
                            
                                Select Case Status
                                    Case Is = "ENROLLED", "PENDING":    Data(8) = Data(8) + 1
                                    Case Is = "CANCEL", "CANCELLED":    Data(6) = Data(6) + 1
                                    Case Is = "WAITLIST", "WAITLISTED": Data(7) = Data(7) + 1
                                    Case Is = "WALK-IN":                Data(10) = Data(10) + 1
                                    Case Is = "NO SHOW":                Data(9) = Data(9) + 1
                                End Select
                        
                                Data(5) = Data(5) + 1                   ' Total Registered
                                Data(11) = Data(8) - Data(9) + Data(10) ' Final Participants
                        
                                Dict(Location) = Data
                            End If
                        Next Cell
                    Next rngArea
                    
              ' Copy the consolidateed data to the Report worksheet.
                Set Rng = wksReport.Range("A5").Resize(columnSize:=UBound(Data) + 1)
                Rng.CurrentRegion.Offset(1, 0).ClearContents
                
                For Each Location In Dict
                    Rng.Offset(r, 0).Value = Dict(Location)
                    r = r + 1
                Next Location
            
            Application.ScreenUpdating = True
        
        wksReport.Activate
        
End Sub