Excel VBA - Splitting/Sorting data into report table

Question

I am trying to sort my raw data into report format. for example my raw data looks like figure below:

Team names, Employee names, country they have traveled, Quarter of the year

I want my data to be split/sort in given format like row contains name of employees in team1 (let's say we have 6 employees in team1) and column contains all 4 quarters, and solution looks like a matrix (6x4) where country name is filled in cells. Also if employee has visited US & UK in same quarter, his cell shows both the names of country in same cell.

Figure 2 is the solution I am looking for:

Please help me, I tried writing this VBA code and successfully sorted employees names in team, BUT i have no idea how do i fill the cells w.r.t. Quarters?

Sub JMP()
Dim team1 As String
Dim team2 As String
Dim team3 As String
Dim team 4 As String

Dim Q1 As String
Dim Q2 As String
Dim Q3 As String
Dim Q4 As String

Dim finalrow As Integer
Dim i As Integer

team1 = Sheets("MasterSheet").Range("I1").Value
team2 = Sheets("MasterSheet").Range("O1").Value
team3 = Sheets("MasterSheet").Range("U1").Value

Q1 = Sheets("MasterSheet").Range("J1").Value
Q2 = Sheets("MasterSheet").Range("K1").Value
Q3 = Sheets("MasterSheet").Range("L1").Value
Q4 = Sheets("MasterSheet").Range("M1").Value

finalrow = Sheets("MasterSheet").Range("B200").End(xlUp).Row
i = 0
For i = 1 To 100
     If Cells(i, 2) = team1 And Cells(i, 5) = Q1 Then
            Range(Cells(i, 3), Cells(i, 4)).Copy
            Range("I100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
    'ElseIf Cells(i, 2) = team 1 And Cells(i, 5) = Q3 Then
            'Range(Cells(i, 3), Cells(i, 4)).Copy
            'Range("I100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
    'ElseIf Cells(i, 2) = Russia And Cells(i, 5) = Q4 Then
            'Range(Cells(i, 3), Cells(i, 4)).Copy
            'Range("I100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats

    End If

Next i


End Sub

Answer 1

Here's the example how to prepare the report using some SQL processing and loops:

Option Explicit

Sub CreateReport()

    Dim objConnection As Object
    Dim lngPosition As Long
    Dim strTeamName As Variant
    Dim objRecordSet As Object
    Dim arrData() As String
    Dim arrEmployees As Variant
    Dim lngEmployee As Long
    Dim lngQuarter As Long
    Dim arrPlaces As Variant

    ' open ADODB connection to this workbook
    Set objConnection = CreateObject("ADODB.Connection")
    objConnection.Open _
        "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "User ID=Admin;" & _
        "Data Source='" & ThisWorkbook.FullName & "';" & _
        "Mode=Read;" & _
        "Extended Properties=""Excel 12.0 Macro;"";"
    ' prepare target worksheet for output
    Sheets("Sheet2").Cells.Delete
    lngPosition = 1
    ' get names of teams
    Set objRecordSet = objConnection.Execute( _
        "SELECT DISTINCT [Team Name] FROM [Sheet1$];")
    ' process each team
    For Each strTeamName In objRecordSet.GetRows
        ' get names of particular team employees
        Set objRecordSet = objConnection.Execute( _
            "SELECT DISTINCT [Traveller's Name] FROM [Sheet1$] WHERE " & _
            "[Team Name] = '" & strTeamName & "';")
        arrEmployees = objRecordSet.GetRows
        ' prepare resulting array
        ReDim arrData(UBound(arrEmployees, 2) + 1, 4)
        arrData(0, 0) = strTeamName
        arrData(0, 1) = "Q1"
        arrData(0, 2) = "Q2"
        arrData(0, 3) = "Q3"
        arrData(0, 4) = "Q4"
        ' process each employee of the team
        For lngEmployee = 0 To UBound(arrEmployees, 2)
            arrData(lngEmployee + 1, 0) = arrEmployees(0, lngEmployee)
            ' process each quarter for the employee of the team
            For lngQuarter = 1 To 4
                ' get all visited places of the employee of the team for the quarter
                Set objRecordSet = objConnection.Execute( _
                    "SELECT DISTINCT [Country/Place] FROM [Sheet1$] WHERE " & _
                    "[Team Name] = '" & strTeamName & "' AND " & _
                    "[Traveller's Name] = '" & arrEmployees(0, lngEmployee) & "' AND " & _
                    "[Quarter] = 'Q" & lngQuarter & "';")
                If Not objRecordSet.EOF Then
                    ' if there are any places then join them and write to array
                    arrPlaces = objRecordSet.GetRows
                    arrPlaces = Application.Index(arrPlaces, , 0) ' make 1d from 2d array
                    arrData(lngEmployee + 1, lngQuarter) = Join(arrPlaces, "+")
                End If
            Next
        Next
        ' put populated array for the team to the sheet
        Output Sheets("Sheet2"), 1, lngPosition, arrData
        lngPosition = lngPosition + 6 ' shift to the right
    Next

End Sub

Sub Output(objSheet As Worksheet, lngTop As Long, lngLeft As Long, arrCells As Variant)
    With objSheet
        .Select
        .Range(.Cells(lngTop, lngLeft), .Cells(UBound(arrCells, 1) + lngTop, UBound(arrCells, 2) + lngLeft)).Value = arrCells
    End With
End Sub

I populated the source worksheet Sheet1 with values as follows:

Then the resulting report looks like as follows:

Note that you can get source data from any other workbook, just replace ThisWorkbook.FullName with actual path. Any changes made to the source workbook must be saved before the macro launched, since the connection should be done to the file, containing actual data. It works on 64-bit version Excel 2010 for me. To make it compatible with .xls and Excel 2003 (where the provider ACE.OLEDB.12.0 isn't installed) you have to replace Provider=Microsoft.ACE.OLEDB.12.0; with Provider=Microsoft.Jet.OLEDB.4.0;, and also in extended properties Excel 12.0 Macro; / Excel 12.0; with Excel 8.0;.