Need help using VBA for report

[ClinicalResearchExcelDude]

Hello, long time lurker but created an account because I can't seem to find the solution.

I use a report tool from my clinical research work that I can download the Excel file. The problem is that I only want to see the most recent status for budget, contract and regulatory for every study we are working on, but our reporting feature doesn't allow this type of filter so I'm forced to use Excel and use VBA to solve this issue. Data starts from A7, and there are hundreds of rows of data to sort/filter. The main column of interest are A (study ID), F (study status to filter contract/budget/regulatory), G (status date, only need the newest for each status from column F), and the last column N (Notes for the status made by the person entering into system). I want, either in the same or new sheet, to create a final report that has the most recent status for budget, contract and regulatory for every unique study ID.

The way I manually have been doing it so far:
1. Hide the rows/columns I don't need
2. Add filter to row 7, which has column headers
3. Study ID - select one study at a time using the filter (column A), click on study status (column F) and type "budget", and sort status date (column G) by newest first. Copy the top row (if any exist) and paste it on a different sheet.
4. Now do the same for step 3 for "contract" and regulatory" in the study status (column F)
5. Now unselect the study ID from 3, and move onto 2nd study, and repeat steps 3 and 4.

As you can imagine, this takes a significant time to do manually. This type of report will be coming in weekly to track changes/updates so I would like to create a macro to expedite this. I'm not a beginner, but I'm definitely not a VBA expert. I only have used a macro recorder to do steps 1 and 2 so far. I have been saving the macro in my personal workbook because I'll be using it on different files every time.

Can a VBA expert guide me in creating such a macro? The file has restrictive data so I can't share it but I'm happy to provide and have discussion about finding an answer.

Thank you!

 

[kevin9999]

OK let's try this. I'm assuming that you will run the macro with the original data sheet active; that the columns match your screenshot (except the headers are on row 1); and that the "regulatory" criteria will be *IBR*. I'd be amazed if this works first time, but you never know. If you hit an error, let me know on what line of the code - and what the error description is. Good Luck!

Option Explicit
Option Compare Text
Sub CREdude()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim ws1LR As Long, ws2LR As Long, ws1LC As Long
    Dim d As Object, arr, i As Long
    
    Application.ScreenUpdating = False
    
    Set ws1 = ActiveSheet
    ThisWorkbook.Sheets.Add(After:=ThisWorkbook.ActiveSheet).Name = "Final Report"
    Set ws2 = Sheets("Final Report")
    
    'Copy the headers
    ws1.Rows(1).Copy ws2.Cells(1, 1)
    ws2.UsedRange.Columns.AutoFit
    
    'Find the last rows/columns
    ws1LR = ws1.Cells.Find("*", , xlFormulas, , 1, 2).Row
    ws2LR = ws2.Cells.Find("*", , xlFormulas, , 1, 2).Row + 1
    ws1LC = ws1.Cells.Find("*", , xlFormulas, , 2, 2).Column + 1
    
    'Get original order of rows
    With ws1.Range(ws1.Cells(2, ws1LC), ws1.Cells(ws1LR, ws1LC))
        .Formula = "=row()"
        .Value = .Value
    End With
    
    'Sort by ID then status date
    ws1.Range(ws1.Cells(1, 1), ws1.Cells(ws1LR, ws1LC)).Sort _
    key1:=ws1.Cells(1, 1), order1:=xlAscending, _
    key2:=ws1.Cells(1, 6), order2:=xlDescending, Header:=xlYes
    
    'Use dictionary to get unique list of IDs
    arr = ws1.Range(ws1.Cells(2, 1), ws1.Cells(ws1LR, 1)).Value
    Set d = CreateObject("scripting.dictionary")
        For i = 1 To UBound(arr, 1)
            d(arr(i, 1)) = 1
        Next i
        
    'Store dictionary keys to use as filter criteria
    arr = Application.Transpose(d.keys)
    
    'Loop through each ID & copy desired rows
    For i = 1 To UBound(arr)
        With ws1.Range(ws1.Cells(1, 1), ws1.Cells(ws1LR, ws1LC))
        On Error Resume Next        '<< if no record found go to next criterion
            .AutoFilter 1, CStr(arr(i, 1)), 1
            .AutoFilter 5, "*budget*"
            ws1.Range("A2:A" & ws1LR).SpecialCells(xlVisible)(1).EntireRow.Copy ws2.Cells(ws2LR, 1)
            .AutoFilter 5, "*contract*"
            ws1.Range("A2:A" & ws1LR).SpecialCells(xlVisible)(1).EntireRow.Copy ws2.Cells(ws2LR + 1, 1)
            .AutoFilter 5, "*IRB*"
            ws1.Range("A2:A" & ws1LR).SpecialCells(xlVisible)(1).EntireRow.Copy ws2.Cells(ws2LR + 2, 1)
            .AutoFilter
        End With
        ws2LR = ws2.Cells.Find("*", , xlFormulas, , 1, 2).Row + 1
    Next i
    
    'Reset the original order
    ws1.Range(ws1.Cells(1, 1), ws1.Cells(ws1LR, ws1LC)).Sort _
    key1:=ws1.Cells(1, ws1LC), order1:=xlAscending, Header:=xlYes
    ws2.Columns(ws1LC).ClearContents
    ws1.Columns(ws1LC).ClearContents
End Sub

 

[SpillerBD]

I would load your data to a PivotTable and drop only the Date into the Value Finds. Then apply a TOP-N filter to the data so the TOp-1st date is shown for each.

 

[kevin9999]

Slight variation on my post #11

Option Explicit
Option Compare Text
Sub CREdude2()
    Dim ws As Worksheet, ws2 As Worksheet, rng As Range
    Dim lr As Long, lc As Long, i As Long
    Dim arrOriginal, arr
    Application.ScreenUpdating = 0

    Set ws = ActiveSheet
    ThisWorkbook.Sheets.Add(After:=ThisWorkbook.ActiveSheet).Name = "Final Report"
    Set ws2 = Sheets("Final Report")
    lr = ws.Cells.Find("*", , xlFormulas, , 1, 2).Row
    lc = ws.Cells.Find("*", , xlFormulas, , 2, 2).Column + 1
    Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc))

    arrOriginal = rng.Resize(, lc + 2).Value
    arr = rng.Value

    For i = 1 To UBound(arr)
        If arr(i, 5) Like "*Budget*" Then
            arr(i, lc) = arr(i, 1) & " | " & "B"
            ElseIf arr(i, 5) Like "*Contract*" Then
            arr(i, lc) = arr(i, 1) & " | " & "C"
            ElseIf arr(i, 5) Like "*IRB*" Then
            arr(i, lc) = arr(i, 1) & " | " & "R"
            Else
            arr(i, lc) = ""
        End If
    Next i
    ws.Cells(1, 1).Resize(lr, lc).Value = arr

    With rng
        .Sort key1:=ws.Cells(1, lc), order1:=1, _
        key2:=ws.Cells(1, 6), order2:=2, _
        Header:=0
    End With

    With ws.Range(ws.Cells(2, lc + 1), ws.Cells(lr, lc + 1))
        .FormulaR1C1 = "=IF(RC[-1]<>R[-1]C[-1],1,0)"
        .Value = .Value
    End With

    With ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc + 1))
        .AutoFilter (lc + 1), 1
        .Resize(, lc - 1).Copy ws2.Cells(1, 1)
        .AutoFilter
    End With
    ws2.UsedRange.Columns.AutoFit

    ws.Cells(1, 1).Resize(lr, lc + 2).Value = arrOriginal
    Application.ScreenUpdating = 1
End Sub

 

[kevin9999]

Have you had the chance to try the code in post #13 yet?