Creating pivot table or report that displays dates worked and in which section.

[Sanantone7]

Hi,

I worked at a nonprofit that needs to track volunteer activity by date worked and section worked in. I cannot figure out a way to make a pivot table that would collect individual volunteer activity by date and then display the 10 dates worked and also a pivot table that would collect individual volunteer activity by location worked for last 10 dates worked. We would be grateful for any support or examples you could share. Thanks very much!! sjp

 

[pbornemeier]

I could not do it with a pivot table but I believe this SQL approach gives you what you asked for.

Create a worksheet "Records" that has 3 columns: Name, Location, Date
Create a worksheet "Last 10"

The code will extract the last 10 dates & location for each name from the Records worksheet to the Last10 worksheet

Option Explicit

Sub ShowLast10DatesWorked()

    'Examine worksheet Records and extract the 10 most recent dates for each Name
    'Records has the following column heads:
    '  Name   Location  Date
    'Results will be written to the worksheet "Last10"

    Dim sSQLString As String
    Dim aryReturn As Variant
    Dim sDBPath As String
    Dim sConnect As String
    Dim lRows As Long
    Dim lCols As Long
    Dim lI As Long, lJ As Long, aryTranspose As Variant
    Dim lRecordsCount As Long
    
    'Dim Conn As New ADODB.Connection
    'Dim rs As New ADODB.Recordset
    'Above 2 lines replaced by next 4 to allow late binding
    Dim conn As Object  ' As ADODB.Connection
    Dim rs As Object  ' As ADODB.Recordset
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    'Initialize Target Worksheet
    With ThisWorkbook.Worksheets("Last10")
        .Cells.Clear   'Clear Sheet
        .Range("A1").Resize(1, 3).Value = Array("Name", "Location", "Date") 'Add Headers
    End With
    
    'Your SQL Statement (Table Name=Sheet Name, coded as: [Sheet1$])
    'Don't forget ending space for all-but-last-row in multi-line statements
              
     sSQLString = _
        "SELECT * " & _
        "FROM [Records$] t " & _
        "WHERE t.date IN (  " & _
            "SELECT TOP 10 date " & _
            "FROM [Records$] t2 " & _
            "WHERE t.name = t2.name) " & _
        "ORDER BY name, date DESC, location"
        
    sDBPath = ThisWorkbook.FullName
    'You can provide the full path of your external file as shown below
    'sDBPath ="C:\InputData.xlsx"
    sConnect = "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & sDBPath & ";HDR=Yes';"
    'If any issue with MSDASQL Provider, Try the Microsoft.Jet.OLEDB:
        'sconnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sDBPath _
        & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
    conn.Open sConnect
    rs.Open sSQLString, conn
    
    '=>Load the Data into an array
    aryReturn = rs.GetRows
    
    'and (optionally) paste data to a worksheet
    '=>Paste the data into a sheet
    'would normally use:
    'ThisWorkbook.Worksheets("Sheet2").Range("A2").CopyFromRecordset rs
    'or
    'ThisWorkbook.Worksheets("Sheet2").Range("A2").Resize(lRows, lCols).Value = _
        Application.WorksheetFunction.Transpose(aryReturn)
    'but CopyFromRecordset & Transpose don't work if there are nulls in the data
    '  (why? I don't know -- sounds like a design flaw)

    'So transpose the ary data in code:
    lCols = UBound(aryReturn, 1) - LBound(aryReturn, 1) + 1
    lRows = UBound(aryReturn, 2) - LBound(aryReturn, 2) + 1
    ReDim aryTranspose(LBound(aryReturn, 2) To UBound(aryReturn, 2), LBound(aryReturn, 1) To UBound(aryReturn, 1))
    For lI = LBound(aryReturn, 2) To UBound(aryReturn, 2)
        For lJ = LBound(aryReturn, 1) To UBound(aryReturn, 1)
            aryTranspose(lI, lJ) = aryReturn(lJ, lI)
        Next
    Next
    'And paste that to a worksheet
    With ThisWorkbook.Worksheets("Last10")
        .Range("A2").Resize(lRows, lCols).Value = aryTranspose
        '.Range("G1").Value = dteData
    End With

    rs.Close    'Close Recordset
    conn.Close  'Close Connection
    
End_Sub:
    
End Sub