Sub CustomDataMetricsMDS()
'Define variables
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim myrows As Integer
Dim LRow As Long
Dim sLastValue As String
Dim cell As Range
Dim urrow As Long
Dim LH As String
Dim LastRow As Long
Application.ScreenUpdating = False
Set ws1 = ActiveSheet
'Add and name worksheets
With ActiveWorkbook.Worksheets
Set ws2 = .Add(After:=ws1)
ws2.Name = "Critical CRFs"
Set ws3 = .Add(After:=ws2)
ws3.Name = "All iCRF Status Metrics"
Set ws4 = .Add(After:=ws3)
ws4.Name = "Critical iCRF Status Metrics"
End With
'Format Source Sheet
ws1.Select
Range("1:4").Delete xlShiftUp
Range("A:A").Delete xlShiftToLeft
Range("B:B").Delete xlShiftToLeft
Range("C:C").Delete xlShiftToLeft
'Delete CRFs with no associated Patient ID
With ws1.Columns("A:N").Resize(ws1.UsedRange.Rows.Count)
.AutoFilter 2, "="
With .Offset(1).SpecialCells(xlCellTypeVisible)
.EntireRow.Delete
End With
.AutoFilter
End With
'Deleting CRFs not needed for screen failures
With ws1.Columns("A:N").Resize(ws1.UsedRange.Rows.Count)
.AutoFilter 13, "="
.AutoFilter 7, "No Data"
.AutoFilter 5, ">=300001"
With .Offset(1, 0).SpecialCells(xlCellTypeVisible)
.EntireRow.Delete
End With
.AutoFilter
End With
myrows = WorksheetFunction.CountA(ws1.Range("A:A"))
For i = 2 To myrows
If Cells(i, 8) = "Locked" Then
Cells(i, 7) = "Locked"
ElseIf Cells(i, 9) = "Reviewed" Then
Cells(i, 7) = "Reviewed"
Else
End If
Next i
Range("H:N").Delete xlShiftToLeft
'Name worksheet and sort by visit and patient
With ws1
.Name = "All iCRF Status"
.Range("B1") = [{"Patient"}]
.Range("C1") = [{"Visit"}]
.Columns("A:G").Sort key1:=.Range("C2"), order1:=xlAscending, key2:=.Range("B2"), order2:=xlAscending, Header:=xlYes
End With
'Label columns on worksheets 2
With ws2.Cells(1).Resize(, 9)
.Value = Array("Site", "Patient", "Visit", "Visit Date", "iCRF Sequence", "iCRF", "iCRF Status")
End With
'Selecting and moving the AE data to the Critical CRFs sheet
With ws1.Columns("A:G").Resize(ws1.UsedRange.Rows.Count)
.AutoFilter 3, "Adverse Event"
With .Offset(1, 0).SpecialCells(xlCellTypeVisible)
.Copy ws2.Cells(2, 1)
End With
.AutoFilter
End With
'Selecting and moving ConMed data to the Critical CRFs sheet
urrow = WorksheetFunction.CountA(ws2.Range("A:A"))
With ws1.Columns("A:G").Resize(ws1.UsedRange.Rows.Count)
.AutoFilter 3, "CONCOMITANT MEDICATIONS"
With .Offset(1, 0).SpecialCells(xlCellTypeVisible)
.Copy ws2.Cells(urrow, 1)
End With
.AutoFilter
End With
'Selecting and moving Transfusion data to the Critical CRFs sheet
With ws1.Columns("A:G").Resize(ws1.UsedRange.Rows.Count)
.AutoFilter 3, "Transfusions"
With .Offset(1, 0).SpecialCells(xlCellTypeVisible)
.Copy ws2.Cells(urrow, 1)
End With
.AutoFilter
End With
'Sort ws1 by Patient
ws1.Select
ws1.Range("B1") = [{"Patient"}]
ws1.Columns("A:I").Sort key1:=ws1.Range("B1"), order1:=xlAscending, Header:=xlYes
'Populating the Visit Date Column
LRow = Cells(Rows.Count, "A").End(xlUp).Row
Do While LRow > 0
If Cells(LRow, 6) = "Visit" Then
sLastValue = Cells(LRow, 4)
Else
Cells(LRow, 4) = sLastValue
End If
LRow = LRow - 1
Loop
Range("D:D").EntireColumn.ColumnWidth = 9
Range("D1").Value = "Visit Date"
'Deleting CRFs that do not need to be counted. These are CRFs with No Data and no associated visit date.
With ws1.Columns("A:G").Resize(ws1.UsedRange.Rows.Count)
.AutoFilter 4, "="
.AutoFilter 7, "No Data"
With .Offset(1, 0).SpecialCells(xlCellTypeVisible)
.EntireRow.Delete
End With
.AutoFilter
End With
'Selecting and moving Eligibility data to the Critical CRFs sheet
With ws1.Columns("A:G").Resize(ws1.UsedRange.Rows.Count)
.AutoFilter 5, "100001"
With .Offset(1, 0).SpecialCells(xlCellTypeVisible)
.Copy ws2.Cells(urrow, 1)
End With
.AutoFilter
End With
'Selecting and moving Disease History data to the Critical CRFs sheet
With ws1.Columns("A:G").Resize(ws1.UsedRange.Rows.Count)
.AutoFilter 5, "300001"
With .Offset(1, 0).SpecialCells(xlCellTypeVisible)
.Copy ws2.Cells(urrow, 1)
End With
.AutoFilter
End With
'Selecting and moving Prior Treatment data to the Critical CRFs sheet
With ws1.Columns("A:G").Resize(ws1.UsedRange.Rows.Count)
.AutoFilter 5, "400001"
With .Offset(1, 0).SpecialCells(xlCellTypeVisible)
.Copy ws2.Cells(urrow, 1)
End With
.AutoFilter
End With
'Selecting and moving Hematology data to the Critical CRFs sheet
With ws1.Columns("A:G").Resize(ws1.UsedRange.Rows.Count)
.AutoFilter 6, "Hematology" & "*"
With .Offset(1, 0).SpecialCells(xlCellTypeVisible)
.Copy ws2.Cells(urrow, 1)
End With
.AutoFilter
End With
'Selecting and moving BL Disease Assessment data to the Critical CRFs sheet
With ws1.Columns("A:G").Resize(ws1.UsedRange.Rows.Count)
.AutoFilter 5, "1800001"
With .Offset(1, 0).SpecialCells(xlCellTypeVisible)
.Copy ws2.Cells(urrow, 1)
End With
.AutoFilter
End With
'Selecting and moving FU Disease Assessment data to the Critical CRFs sheet
With ws1.Columns("A:G").Resize(ws1.UsedRange.Rows.Count)
.AutoFilter 3, "<>" & "Screening"
.AutoFilter 6, "Disease Assessment"
With .Offset(1, 0).SpecialCells(xlCellTypeVisible)
.Copy ws2.Cells(urrow, 1)
End With
.AutoFilter
End With
'Selecting and moving Response Assessment data to the Critical CRFs sheet
With ws1.Columns("A:G").Resize(ws1.UsedRange.Rows.Count)
.AutoFilter 6, "Response Assessment"
With .Offset(1, 0).SpecialCells(xlCellTypeVisible)
.Copy ws2.Cells(urrow, 1)
End With
.AutoFilter
End With
'Selecting and moving EOS data to the Critical CRFs sheet
With ws1.Columns("A:G").Resize(ws1.UsedRange.Rows.Count)
.AutoFilter 3, "End of Study"
With .Offset(1, 0).SpecialCells(xlCellTypeVisible)
.Copy ws2.Cells(urrow, 1)
End With
.AutoFilter
End With
'***PIVOT TABLE FOR ALL CRFS*****
'----------------------------------------------------------------------------------------------------------
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
Worksheets("All iCRF Status").Range("A1").CurrentRegion, Version:=xlPivotTableVersion12). _
CreatePivotTable TableDestination:="'All iCRF Status Metrics'!R3C1", TableName:="All iCRF Status" _
, DefaultVersion:=xlPivotTableVersion12
ws3.Select
Cells(3, 1).Select
With ActiveSheet.PivotTables("All iCRF Status").PivotFields("Site")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("All iCRF Status").PivotFields("Patient")
.Orientation = xlRowField
.Position = 2
End With
With ActiveSheet.PivotTables("All iCRF Status").PivotFields("iCRF Status")
.Orientation = xlColumnField
.Position = 1
End With
ActiveSheet.PivotTables("All iCRF Status").AddDataField ActiveSheet.PivotTables( _
"All iCRF Status").PivotFields("iCRF"), "Count of iCRF", xlCount
With ActiveSheet.PivotTables("All iCRF Status").PivotFields("Count of iCRF")
.Calculation = xlPercentOfRow
.NumberFormat = "0.0%"
End With
ActiveSheet.PivotTables("All iCRF Status").RowGrand = False
ActiveSheet.PivotTables("All iCRF Status").CompactLayoutRowHeader = "Site"
ActiveSheet.PivotTables("All iCRF Status").CompactLayoutColumnHeader = "iCRF Status"
If ActiveSheet.PivotTables("All iCRF Status").PivotFields("Patient").Orientation = xlHidden Then
ActiveSheet.PivotTables("All iCRF Status").PivotFields("Patient").Orientation = xlRowField
Else: ActiveSheet.PivotTables("All iCRF Status").PivotFields("Patient").Orientation = xlHidden
End If
Cells(3, 1).Value = "All iCRF Status Metrics"
Cells(3, 1).Interior.ColorIndex = 49
Cells(3, 1).Font.Color = vbWhite
'***PIVOT TABLE FOR CRITICAL CRFS*****
'----------------------------------------------------------------------------------------------------------
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
Worksheets("Critical CRFs").Range("A1").CurrentRegion, Version:=xlPivotTableVersion12). _
CreatePivotTable TableDestination:="'Critical iCRF Status Metrics'!R3C1", TableName:="Critical iCRF Status" _
, DefaultVersion:=xlPivotTableVersion12
ws4.Select
Cells(3, 1).Select
With ActiveSheet.PivotTables("Critical iCRF Status").PivotFields("Site")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("Critical iCRF Status").PivotFields("Patient")
.Orientation = xlRowField
.Position = 2
End With
With ActiveSheet.PivotTables("Critical iCRF Status").PivotFields("iCRF Status")
.Orientation = xlColumnField
.Position = 1
End With
ActiveSheet.PivotTables("Critical iCRF Status").AddDataField ActiveSheet.PivotTables( _
"Critical iCRF Status").PivotFields("iCRF"), "Count of iCRF", xlCount
With ActiveSheet.PivotTables("Critical iCRF Status").PivotFields("Count of iCRF")
.Calculation = xlPercentOfRow
.NumberFormat = "0.0%"
End With
ActiveSheet.PivotTables("Critical iCRF Status").RowGrand = False
ActiveSheet.PivotTables("Critical iCRF Status").CompactLayoutRowHeader = "Site"
ActiveSheet.PivotTables("Critical iCRF Status").CompactLayoutColumnHeader = "iCRF Status"
If ActiveSheet.PivotTables("Critical iCRF Status").PivotFields("Patient").Orientation = xlHidden Then
ActiveSheet.PivotTables("Critical iCRF Status").PivotFields("Patient").Orientation = xlRowField
Else: ActiveSheet.PivotTables("Critical iCRF Status").PivotFields("Patient").Orientation = xlHidden
End If
Cells(3, 1).Value = "Critical iCRF Status Metrics"
Cells(3, 1).Interior.ColorIndex = 49
Cells(3, 1).Font.Color = vbWhite
'setting up pages to be exported to pdf
LH = "MDS Custom CRF Metrics Report"
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
ws3.Select
With ws3.PageSetup
.PrintArea = "$A$3:$I$" & LastRow
.Orientation = xlLandscape
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.FitToPagesWide = 1
.FitToPagesTall = False
.Zoom = False
.LeftHeader = LH
.CenterHeader = ActiveSheet.Name
.RightHeader = "Printed on &D"
End With
ws4.Select
With ws4.PageSetup
.PrintArea = "$A$3:$I$" & LastRow
.Orientation = xlLandscape
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.FitToPagesWide = 1
.FitToPagesTall = False
.Zoom = False
.LeftHeader = LH
.CenterHeader = ActiveSheet.Name
.RightHeader = "Printed on &D"
End With
End Sub
