Sub PrintExit()
Dim wdApp As Word.Application, wdDoc As Word.Document
Dim datasheet As Worksheet
Dim exitsheet As Worksheet
Dim testresultfail As String
Dim testresultpartialfail As String
Dim finalrow As Integer
Dim i As Integer
Application.StatusBar = "Creating new document..."
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Add
With wdDoc
.SaveAs2 FileName:="HIPAA Exit Wording.docx"
.PageSetup.Orientation = wdOrientPortrait
End With
Application.ScreenUpdating = False
Set datasheet = Sheet2
Set exitsheet = Sheet3
Sheets("Exit").Visible = True
testresultfail = "Fail"
testresultpartialfail = "Partial Fail"
exitsheet.Range("A1:ZZ500").ClearContents
datasheet.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To finalrow
If Cells(i, 6) = testresultfail Or Cells(i, 6) = testresultpartialfail Then
Range(Cells(i, 1), Cells(i, 7)).Copy
exitsheet.Select
Range("a200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
datasheet.Select
End If
Next i
exitsheet.Select
ActiveWorkbook.Worksheets("Exit").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Exit").Sort.SortFields.Add2 Key:=Range("A2:A7"), _
SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
"Identify,Protect,Detect,Respond,Recover", DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Exit").Sort.SortFields.Add2 Key:=Range("F2:F7"), _
SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
"Fail,Partial Fail", DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Exit").Sort
.SetRange Range("A2:G98")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
exitsheet.Select
Cells(1, 8).Value = "Identify"
Cells(1, 9).Value = "Protect"
Cells(1, 10).Value = "Detect"
Cells(1, 11).Value = "Respond"
Cells(1, 12).Value = "Recover"
For i = 2 To finalrow
If Cells(i, 1) = "IDENTIFY" Then
Cells(i, 8).Value = Cells(i, 3).Value & " " & Cells(i, 7).Value
ElseIf Cells(i, 1) = "PROTECT" Then
Cells(i, 9).Value = Cells(i, 3).Value & " " & Cells(i, 7).Value
ElseIf Cells(i, 1) = "DECTECT" Then
Cells(i, 10).Value = Cells(i, 3).Value & " " & Cells(i, 7).Value
ElseIf Cells(i, 1) = "RESPOND" Then
Cells(i, 11).Value = Cells(i, 3).Value & " " & Cells(i, 7).Value
ElseIf Cells(i, 1) = "RECOVER" Then
Cells(i, 12).Value = Cells(i, 3).Value & " " & Cells(i, 7).Value
End If
Dim blankrng As Range
On Error GoTo NoBlanks
Set blankrng = Range("H1:L98").SpecialCells(xlCellTypeBlanks)
blankrng.Rows.Delete shift:=xlShiftUp
NoBlanks:
Resume Next
Next i
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Exit" Then
Application.StatusBar = "Copying data from " & ws.Name & "..."
If Range("H2") <> "" Then
ws.Range("H1").Copy
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.PasteAndFormat wdFormatPlainText
.ParagraphFormat.SpaceAfter = 0
.Font.Name = "Times New Roman"
.Font.Color = wdColorBlank
.Font.Bold = True
.Font.Italic = False
.Font.Allcaps = False
.Font.Size = 11
.Borders(wdBorderBottom).Visible = True
End With
ws.Range("H2:H98").SpecialCells(xlCellTypeConstants).Copy
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.PasteAndFormat wdFormatPlainText
.ListFormat.ApplyBulletDefault
.ParagraphFormat.SpaceAfter = 0
.Font.Name = "Times New Roman"
.Font.Color = wdColorBlank
.Font.Bold = False
.Font.Italic = False
.Font.Allcaps = False
.Font.Size = 11
.Borders(wdBorderBottom).Visible = False
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
End With
Else: End If
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.Paragraphs.Outdent
.ListFormat.RemoveNumbers
End With
If Range("I2") <> "" Then
ws.Range("I1").Copy
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.Paragraphs.Outdent
.ListFormat.RemoveNumbers
.PasteAndFormat wdFormatPlainText
.ParagraphFormat.SpaceAfter = 0
.Font.Name = "Times New Roman"
.Font.Color = wdColorBlank
.Font.Bold = True
.Font.Italic = False
.Font.Allcaps = False
.Font.Size = 11
.Borders(wdBorderBottom).Visible = True
End With
ws.Range("I2:I98").SpecialCells(xlCellTypeConstants).Copy
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.PasteAndFormat wdFormatPlainText
.ListFormat.ApplyBulletDefault
.ParagraphFormat.SpaceAfter = 0
.Font.Name = "Times New Roman"
.Font.Color = wdColorBlank
.Font.Bold = False
.Font.Italic = False
.Font.Allcaps = False
.Font.Size = 11
.Borders(wdBorderBottom).Visible = False
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
End With
Else: End If
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.Paragraphs.Outdent
.ListFormat.RemoveNumbers
End With
If Range("J2") <> "" Then
ws.Range("J1").Copy
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.Paragraphs.Outdent
.ListFormat.RemoveNumbers
.PasteAndFormat wdFormatPlainText
.ParagraphFormat.SpaceAfter = 0
.Font.Name = "Times New Roman"
.Font.Color = wdColorBlank
.Font.Bold = True
.Font.Italic = False
.Font.Allcaps = False
.Font.Size = 11
.Borders(wdBorderBottom).Visible = True
End With
ws.Range("J2:J98").SpecialCells(xlCellTypeConstants).Copy
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.PasteAndFormat wdFormatPlainText
.ListFormat.ApplyBulletDefault
.ParagraphFormat.SpaceAfter = 0
.Font.Name = "Times New Roman"
.Font.Color = wdColorBlank
.Font.Bold = False
.Font.Italic = False
.Font.Allcaps = False
.Font.Size = 11
.Borders(wdBorderBottom).Visible = False
End With
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
Else: End If
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.Paragraphs.Outdent
.ListFormat.RemoveNumbers
End With
If Range("K2") <> "" Then
ws.Range("K1").Copy
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.Paragraphs.Outdent
.ListFormat.RemoveNumbers
.PasteAndFormat wdFormatPlainText
.ParagraphFormat.SpaceAfter = 0
.Font.Name = "Times New Roman"
.Font.Color = wdColorBlank
.Font.Bold = True
.Font.Italic = False
.Font.Allcaps = False
.Font.Size = 11
.Borders(wdBorderBottom).Visible = True
End With
ws.Range("K2:K98").SpecialCells(xlCellTypeConstants).Copy
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.PasteAndFormat wdFormatPlainText
.ListFormat.ApplyBulletDefault
.ParagraphFormat.SpaceAfter = 0
.Font.Name = "Times New Roman"
.Font.Color = wdColorBlank
.Font.Bold = False
.Font.Italic = False
.Font.Allcaps = False
.Font.Size = 11
.Borders(wdBorderBottom).Visible = False
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
End With
Else: End If
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.Paragraphs.Outdent
.ListFormat.RemoveNumbers
End With
If Range("K2") <> "" Then
ws.Range("L1").Copy
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.Paragraphs.Outdent
.ListFormat.RemoveNumbers
.PasteAndFormat wdFormatPlainText
.ParagraphFormat.SpaceAfter = 0
.Font.Name = "Times New Roman"
.Font.Color = wdColorBlank
.Font.Bold = True
.Font.Italic = False
.Font.Allcaps = False
.Font.Size = 11
.Borders(wdBorderBottom).Visible = True
End With
ws.Range("L2:L98").SpecialCells(xlCellTypeConstants).Copy
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.PasteAndFormat wdFormatPlainText
.ListFormat.ApplyBulletDefault
.ParagraphFormat.SpaceAfter = 0
.Font.Name = "Times New Roman"
.Font.Color = wdColorBlank
.Font.Bold = False
.Font.Italic = False
.Font.Allcaps = False
.Font.Size = 11
.Borders(wdBorderBottom).Visible = False
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
End With
Else: End If
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.Paragraphs.Outdent
.ListFormat.RemoveNumbers
End With
Application.CutCopyMode = False
End If
Next ws
Set ws = Nothing
Application.StatusBar = "Cleaning up..."
With wdApp.ActiveWindow
If .View.SplitSpecial = wdPaneNone Then
.ActivePane.View.Type = wdPrintView
Else
.View.Type = wdPrintView
End If
End With
Set wdDoc = Nothing
wdApp.Visible = True
Set wdApp = Nothing
Application.StatusBar = False
exitsheet.Range("A1:ZZ500").ClearContents
Sheets("Exit").Visible = False
Sheets("Audit Data").Activate
ActiveSheet.Cells(2, 2).Select
End Sub