Installing the Roster Reviewer DocsMacro

(Revised 12/24/2014)

Installing the ReviewerRosterDocsmacro within MS Excel

The easiest way to install the available Excel Macros is to replace or create a new MS Excel template file using the one that has these macros already. Instructions for all installation methods are listed below.

These steps have to be re-done if MS Excel is re-installed on the computer or the computer is replaced.

Installing the macro(s) by replacing or adding a newMS Excel Personal.XLSB template file

  1. Close the MS Excel program
  2. Copy the PERSONAL.XLSB file from the following location: R:\SRP-DEAS-SHARED\Tools and Technical Guides\Excel-Roster+Print+PubMedTitle Macros
  3. Paste it into the following folder (substitute the applicable NIH login name where specified):
  4. Windows 7: C:\Users\NIHLogInName\AppData\Roaming\Microsoft\Excel\XLSTART

Note: If the ‘Application Data’ or ’App Data’ folder is not visible, the following Tools Menu\Folder Options default needs to be set.

  1. Open Excel
  2. The macro will now be available in the MS Excel program and can be added to the Quick Access Toolbar from the ‘Choose commands from: Macros’ list

If there is already a Personal Workbook template file established that cannot be replaced, add the macro from within MS Excel

  1. Open MS Excel
  2. Click on the Developer tab > Visual Basic button to open the Visual Basic window shown below
  1. Highlight and copy the text in Appendix A, then paste it into the window as shown above
  2. Select File\Save Personal.XLSB and then Select File\‘Close and Return to Microsoft Excel’
  1. The macro will now be available in the MS Excel program and can be added to the Quick Access Toolbar from the ‘Choose commands from: Macros’ list

Appendix A: RosterReviewerDocsMacro

Sub RosterReviewerDocsMacro()

ActiveSheet.Name = "Roster Data"

Application.Worksheets.Add , After:=ActiveSheet

ActiveSheet.Name = "Staff Data"

Application.Worksheets.Add , After:=ActiveSheet

ActiveSheet.Name = "Staff Sign In Form"

Application.Worksheets.Add , After:=ActiveSheet

ActiveSheet.Name = "Reviewer Sign In Form"

Worksheets("Roster Data").Activate

ActiveSheet.Columns("B:B").Select

Selection.EntireColumn.Insert

Selection.EntireColumn.Insert

Selection.EntireColumn.Insert

ActiveSheet.Range("B1").Value = "Ltr+Env-Last Name"

ActiveSheet.Range("C1").Value = "Ltr+Env-First Name"

ActiveSheet.Range("D1") = "Degree"

ActiveSheet.Range("I:N").ColumnWidth = 30

'select the cell with the text to split

ActiveSheet.Range("A2:A2").Select

'the results will be placed in same row in next 3 columns

'provide the name of the sheet that has the data to be

'split on it

Const dataSheetName = "Roster Data" ' change as required

' column it is in, change as needed

Const txtColumn = "A"

' first row containing such text

Const txtFirstRow = 2

'these are columns you want to put the results into change as needed

Const leftPartCol = "B"

Const midPartCol = "C"

Const rightPartCol = "D"

'define the character to split at

Const splitChar = ","

'this will represent the data sheet

Dim dataWS As Worksheet

'these will reference the list of complete text entries

Dim theListToBeSplit As Range

Dim anyCellToBeSplit As Range

Dim rawText As String

Dim s1 As Integer

Dim s2 As Integer

Set dataWS = ActiveWorkbook.Worksheets(dataSheetName)

Set theListToBeSplit = dataWS.Range(txtColumn & txtFirstRow & ":" & dataWS.Range(txtColumn & Rows.Count).End(xlUp).Address)

For Each anyCellToBeSplit In theListToBeSplit

rawText = anyCellToBeSplit.Value

s1 = InStr(rawText, splitChar)

If s1 > 0 Then

'found 1st comma, find second

s2 = InStr(s1 + 1, rawText, splitChar)

'found 2 commas, go to work

If s2 = 0 Then

dataWS.Range(leftPartCol & anyCellToBeSplit.Row) = Left(rawText, s1 - 1)

dataWS.Range(midPartCol & anyCellToBeSplit.Row) = Mid(rawText, s1 + 1)

ElseIf s2 > s1 Then

dataWS.Range(leftPartCol & anyCellToBeSplit.Row) = Left(rawText, s1 - 1)

dataWS.Range(midPartCol & anyCellToBeSplit.Row) = Mid(rawText, s1 + 1, s2 - (s1 + 1))

dataWS.Range(rightPartCol & anyCellToBeSplit.Row) = Right(rawText, Len(rawText) - s2)

End If

End If

Next

'housekeeping - release assigned resources back to the system

Set theListToBeSplit = Nothing

Set dataWS = Nothing

'Trims leading spaces from B,C,D columns

Dim cell As Range

For Each cell In ActiveSheet.UsedRange.Columns("B:D").Cells

x = x + 1

cell.Value = WorksheetFunction.Trim(cell.Value)

Next

'Moves SRO name, phone and email to columns K, L, M and names columns

Dim myStringSRO As String

Role = Range("E:E").Value

SROFName = Range("C:C").Value

SROLName = Range("B:B").Value

SRODeg = Range("D:D").Value

For i = 1 To UBound(SROFName)

If Application.Proper(Role(i, 1)) = "Scientific Review Administrator" Then

myStringSRO = SROFName(i, 1) & " " & SROLName(i, 1) & ", " & SRODeg(i, 1)

ElseIf Application.Proper(Role(i, 1)) = "Scientific Review Officer" Then

myStringSRO = SROFName(i, 1) & " " & SROLName(i, 1) & ", " & SRODeg(i, 1)

End If

Next

Worksheets("Roster Data").Cells(1, 11).Value = "SROName"

If myStringSRO > "" Then

Worksheets("Roster Data").Cells(2, 11).Value = myStringSRO

End If

Dim myStringSROPhone As String

Role = Range("E:E").Value

SROPhone = Range("G:G").Value

For i = 1 To UBound(SROPhone)

If Application.Proper(Role(i, 1)) = "Scientific Review Administrator" Then

myStringSROPhone = SROPhone(i, 1)

ElseIf Application.Proper(Role(i, 1)) = "Scientific Review Officer" Then

myStringSROPhone = SROPhone(i, 1)

End If

Next

Worksheets("Roster Data").Cells(1, 12).Value = "SROPhone"

If myStringSROPhone > "" Then

Worksheets("Roster Data").Cells(2, 12).Value = myStringSROPhone

End If

Dim myStringSROEmail As String

Role = Range("E:E").Value

SROEmail = Range("I:I").Value

For i = 1 To UBound(SROEmail)

If Application.Proper(Role(i, 1)) = "Scientific Review Administrator" Then

myStringSROEmail = SROEmail(i, 1)

ElseIf Application.Proper(Role(i, 1)) = "Scientific Review Officer" Then

myStringSROEmail = SROEmail(i, 1)

End If

Next

Worksheets("Roster Data").Cells(1, 13).Value = "SROEmail"

If myStringSROEmail > "" Then

Worksheets("Roster Data").Cells(2, 13).Value = myStringSROEmail

End If

'Fills SRO info down rows

LastRow = Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To LastRow

If Range("A" & i).Value > "" Then

Range("K" & i).Value = Cells(2, 11).Value

Range("L" & i).Value = Cells(2, 12).Value

Range("M" & i).Value = Cells(2, 13).Value

End If

Next i

'Enters Chairperson phrase in column J

ActiveSheet.Range("J1").Value = "EndPhrase"

LastRow = Range("E" & Rows.Count).End(xlUp).Row

For i = 2 To LastRow

If Range("E" & i).Value = "Chairperson" Then

Range("J" & i).Value = "The scientific and technical merits of the submissions were evaluated in an expert manner thanks in great measure to the time and effort you expended before the meeting and your skills as Chair. Your thoughtful, balanced attention to the important elements of the initiative, each submission, and each evaluation, plus your courteous interactions with committee members were crucial to allowing the NIAID to identify the most meritorious biomedical research."

Else

Range("J" & i).Value = "Your expert participation contributed to the success of the meeting and your time and effort in preparing to participate are sincerely appreciated. The comments and recommendations of all committee members will enable NIAID to identify the most meritorious biomedical research."

End If

Next i

'Create sign up, label and tent card Last Name Column

ActiveSheet.Columns("B:B").Select

Selection.EntireColumn.Insert

Columns("C:C").Copy

Columns("B:B").Select

ActiveSheet.Paste

Application.CutCopyMode = False

ActiveSheet.Range("B1").Value = "Label+TentCard LastName"

'Create sign up, label and tent card First Name Column

ActiveSheet.Columns("B:B").Select

Selection.EntireColumn.Insert

Columns("E:E").Copy

Columns("B:B").Select

ActiveSheet.Paste

Application.CutCopyMode = False

ActiveSheet.Range("B1").Value = "Label+TentCard FirstName"

'Change Reviewer Name and Address used for mailing address fields to all caps

Dim y As Range

For Each y In Range("D2:F400")

y.Value = UCase(y)

Next y

For Each y In Range("H2:H400")

y.Value = UCase(y)

Next y

'Adds Dr. column value based on degree column not being blank

ActiveSheet.Columns("B:B").Select

Selection.EntireColumn.Insert

ActiveSheet.Range("B1").Value = "Dr."

LastRow = Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To LastRow

If Range("G" & i).Value > "" Then

Range("B" & i).Value = "Dr."

ElseIf Range("G" & i).Value = "" Then

Range("B" & i).Value = "Mr./Ms."

End If

Next i

ActiveSheet.Range("B:B").ColumnWidth = 5

'Proper Case for First and Last Name column data

For Each y In Range("C2:D400")

y.Value = Application.WorksheetFunction.Proper(y.Value)

Next y

'Enters Chairperson phrase in column Q

ActiveSheet.Range("Q1").Value = "BeginPhrase"

LastRow = Range("H" & Rows.Count).End(xlUp).Row

For i = 2 To LastRow

If Range("H" & i).Value = "Chairperson" Then

Range("Q" & i).Value = "On behalf of the National Institutes of Health and the NIAID I thank you for your exceptional work as Chairperson and peer reviewer for the"

Else

Range("Q" & i).Value = "On behalf of the National Institutes of Health and the NIAID I thank you for participating in the"

End If

Next i

'Deletes non-SEP and chairperson rows

Dim z As Long

Dim FoundRowToDelete As Boolean

Dim OriginalCalculationMode As Long

Dim RowsToDelete As Range

Dim SearchItems() As String

Dim DataStartRow As Long

Dim SearchColumn As String

Dim SheetName As String

Dim DstShtName As String

' Choose the row you want the search and delete to start on

' Choose the column to search and delete to use for deletion

' Choose the sheet in the workbook you want this macro to be run on

DataStartRow = 2

SearchColumn = "H"

SheetName = "Roster Data"

DstShtName = "Staff Data"

' Enter the terms you want to be used for criteria for deletion

' All terms entered below are CASE SENSITIVE and need to be

'separated by a comma

SearchItems = Split("Assistant,Admin,Representative,Officer", ",")

With Worksheets(SheetName)

LastRow = .Cells(.Rows.Count, SearchColumn).End(xlUp).Row

For x = LastRow To DataStartRow Step -1

FoundRowToDelete = False

For z = 0 To UBound(SearchItems)

If InStr(.Cells(x, SearchColumn).Value, SearchItems(z)) Then

FoundRowToDelete = True

Exit For

End If

Next

If FoundRowToDelete Then

If RowsToDelete Is Nothing Then

Set RowsToDelete = .Cells(x, SearchColumn)

Else

Set RowsToDelete = Union(RowsToDelete, .Cells(x, SearchColumn))

End If

If RowsToDelete.Areas.Count > 100 Then

RowsToDelete.EntireRow.Delete

Set RowsToDelete = Nothing

End If

End If

Next

End With

If Not RowsToDelete Is Nothing Then

LastRow = Sheets(DstShtName).Cells(Rows.Count, SearchColumn).End(xlUp).Row

RowsToDelete.EntireRow.Copy Sheets(DstShtName).Cells(LastRow + 1, 1)

RowsToDelete.EntireRow.Delete

End If

'Create reviewer meeting Sign In Form in excel based on standard doc

Worksheets("Reviewer Sign In Form").Activate

Dim objXL As Object

Set objXL = CreateObject("Excel.Application")

With ActiveSheet.PageSetup

.LeftHeader = "&""Times New Roman""&12ZAI1-"

.CenterHeader = _

"&B &""Times New Roman""&13*** ADMINISTRATIVE CONFIDENTIAL***&B" & Chr(10) & "&B&UREVIEWER ATTENDANCE LIST&U&B"

.RightFooter = "Page &P of &N"

.LeftMargin = objXL.InchesToPoints(0.7)

.RightMargin = objXL.InchesToPoints(0.7)

.TopMargin = objXL.InchesToPoints(1.1)

.BottomMargin = objXL.InchesToPoints(0.7)

.HeaderMargin = objXL.InchesToPoints(0.5)

.FooterMargin = objXL.InchesToPoints(0.4)

End With

ActiveSheet.Range("A1").Value = "MEETING TITLE: "

ActiveSheet.Range("A3").Value = "PLACE OF MEETING: "

ActiveSheet.Range("A5").Value = "DATE OF MEETING: "

With ActiveSheet.Range("A1:B6")

.ColumnWidth = 45

.Font.Name = "Times New Roman"

.Font.Size = 11

.Font.Bold = True

.RowHeight = 14

End With

With ActiveSheet.Range("A7:B7")

.ColumnWidth = 45

.Font.Name = "Times New Roman"

.Font.Size = 13

.Font.Bold = True

.RowHeight = 18

End With

With ActiveSheet.Range("A8:B400")

.ColumnWidth = 45

.Font.Name = "Times New Roman"

.Font.Size = 12

.RowHeight = 24

.VerticalAlignment = xlCenter

End With

ActiveSheet.Range("A7").Value = "Reviewer Name"

ActiveSheet.Range("B7").Value = "Signature"

With ActiveSheet.Range("A7:B7")

.HorizontalAlignment = xlCenter

.Interior.ColorIndex = 15

End With

Dim rng As Range

Set rng = Range("A7:B400")

With rng.Borders

.LineStyle = xlContinuous

.Weight = xlThin

.Color = vbBlack

End With

Sheets("Roster Data").Select

Dim lRow As Long

Set rng = Range("B2").End(xlDown)

Debug.Print rng.Address(External:=True)

lRow = rng.Row

For i = 2 To lRow

ActiveWorkbook.Sheets("Reviewer Sign In Form").Cells(i + 6, 1) = Cells(i, 2) & " " & Cells(i, 3) & " " & Cells(i, 4)

Next i

Worksheets("Reviewer Sign In Form").Range("A8", "A" & ActiveSheet.Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Worksheets("Reviewer Sign In Form").Activate

ActiveWindow.View = xlPageLayoutView

'Create staff meeting Sign In Form in excel based on standard doc

Worksheets("Staff Sign In Form").Activate

Set objXL = CreateObject("Excel.Application")

With ActiveSheet.PageSetup

.LeftHeader = "&""Times New Roman""&12ZAI1-"

.CenterHeader = _

"&B &""Times New Roman""&13*** ADMINISTRATIVE CONFIDENTIAL***&B" & Chr(10) & "&B&UNIH STAFF ATTENDANCE LIST&U&B"

.RightFooter = "Page &P of &N"

.LeftMargin = objXL.InchesToPoints(0.7)

.RightMargin = objXL.InchesToPoints(0.7)

.TopMargin = objXL.InchesToPoints(1.1)

.BottomMargin = objXL.InchesToPoints(0.7)

.HeaderMargin = objXL.InchesToPoints(0.5)

.FooterMargin = objXL.InchesToPoints(0.4)

End With

ActiveSheet.Range("A1").Value = "MEETING TITLE: "

ActiveSheet.Range("A3").Value = "PLACE OF MEETING: "

ActiveSheet.Range("A5").Value = "DATE OF MEETING: "

With ActiveSheet.Range("A1:B6")

.ColumnWidth = 45

.Font.Name = "Times New Roman"

.Font.Size = 11

.Font.Bold = True

.RowHeight = 14

End With

With ActiveSheet.Range("A7:C7")

.ColumnWidth = 30

.Font.Name = "Times New Roman"

.Font.Size = 13

.Font.Bold = True

.RowHeight = 18

End With

ActiveSheet.Range("A7").Value = "Staff Name"

ActiveSheet.Range("B7").Value = "Signature"

ActiveSheet.Range("C7").Value = "Division"

With ActiveSheet.Range("A8:C100")

.ColumnWidth = 30

.Font.Name = "Times New Roman"

.Font.Size = 12

.RowHeight = 24

.VerticalAlignment = xlCenter

End With

With ActiveSheet.Range("A7:C7")

.HorizontalAlignment = xlCenter

.Interior.ColorIndex = 15

End With

Set rng = Range("A7:C100")

With rng.Borders

.LineStyle = xlContinuous

.Weight = xlThin

.Color = vbBlack

End With

Sheets("Staff Data").Select

Set rng = Range("B2").End(xlDown)

Debug.Print rng.Address(External:=True)

lRow = rng.Row

For i = 2 To lRow

ActiveWorkbook.Sheets("Staff Sign In Form").Cells(i + 6, 1) = Cells(i, 2) & " " & Cells(i, 3) & " " & Cells(i, 4)

Next i

Worksheets("Staff Sign In Form").Columns("A").Replace What:="Mr./Ms. ", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True

Worksheets("Staff Sign In Form").Range("A8", "A" & ActiveSheet.Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Worksheets("Staff Sign In Form").Activate

ActiveSheet.Range("A1:A1").Select

ActiveWindow.View = xlPageLayoutView

End Sub

1