Sub Vulnerability()'
' Vulnerability Macro
'
'
Rows("1:3").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
Set Rng = Range(Range("A4"), Range("A4").SpecialCells(xlLastCell))
Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Rng, , xlYes)
tbl.Name = "hmvt"
tbl.TableStyle = "TableStyleLight8"
Range("A1").Select
ActiveCell.FormulaR1C1 = "Total Number of Records"
Range("B1").Select
ActiveCell.FormulaR1C1 = "=COUNTA(hmvt[[CIO_]:[CIO_]])"
Range("A2").Select
ActiveCell.FormulaR1C1 = "Total Number Open"
Range("B2").Select
ActiveCell.FormulaR1C1 = _
"=COUNTBLANK(hmvt[[GITRM confirmed remediation]:[GITRM confirmed remediation]])"
Range("B3").Select
Sheets("Backlog Reclassified").Select
Rows("1:3").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Set Rng = Range(Range("A4"), Range("A4").SpecialCells(xlLastCell))
Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Rng, , xlYes)
tbl.Name = "cht"
tbl.TableStyle = "TableStyleLight8"
Range("A1").Select
ActiveCell.FormulaR1C1 = "Total Number of Records"
Range("B1").Select
ActiveCell.FormulaR1C1 = "=COUNTA(cht[[CIO_]:[CIO_]])"
Range("A2").Select
ActiveCell.FormulaR1C1 = "Total Number Open"
Range("B2").Select
ActiveCell.FormulaR1C1 = _
"=COUNTBLANK(cht[[GITRM confirmed remediation]:[GITRM confirmed remediation]])"
Range("cht[[#Headers],[CIO_]]").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "Source2"
ActiveCell.Offset(1).Select
ActiveCell.FormulaR1C1 = "Reclassified"
ActiveCell.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
Sheets("Backlog Internal Medium").Select
Range("hmvt[[#Headers],[CIO_]]").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "Source2"
ActiveCell.Offset(1).Select
ActiveCell.FormulaR1C1 = "Internal Medium"
ActiveCell.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
Worksheets.Add(After:=Worksheets(Sheets.Count)).Name = "Combined"
Sheets("Backlog Internal Medium").Select
ActiveSheet.ListObjects("hmvt").Range.Select
Selection.Copy
Sheets("Combined").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Set Rng = Range(Range("A1"), Range("A1").SpecialCells(xlLastCell))
Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Rng, , xlYes)
tbl.Name = "combined"
tbl.TableStyle = "TableStyleLight8"
Range("A1").Select
currentColumn = 1
While currentColumn <= ActiveSheet.UsedRange.Columns.Count
columnHeading = ActiveSheet.UsedRange.Cells(1, currentColumn).Value
keepColumn = False
If columnHeading = "LTO" Then keepColumn = True
If columnHeading = "STO" Then keepColumn = True
If columnHeading = "Last Detected" Then keepColumn = True
If columnHeading = "First Detected" Then keepColumn = True
If columnHeading = "Updated Last Detected Date" Then keepColumn = True
If columnHeading = "Key - IP-QID-Port" Then keepColumn = True
If columnHeading = "IP" Then keepColumn = True
If columnHeading = "ComputerName" Then keepColumn = True
If columnHeading = "OS" Then keepColumn = True
If columnHeading = "QID" Then keepColumn = True
If columnHeading = "PORT" Then keepColumn = True
If columnHeading = "AppCat" Then keepColumn = True
If columnHeading = "Application_Name" Then keepColumn = True
If columnHeading = "SERVERPURPOSE" Then keepColumn = True
If columnHeading = "Remediation Approach" Then keepColumn = True
If columnHeading = "CxO Planned Date" Then keepColumn = True
If columnHeading = "GITRM confirmed remediation" Then keepColumn = True
If columnHeading = "Comments" Then keepColumn = True
If columnHeading = "NOTE" Then keepColumn = True
If columnHeading = "Source2" Then keepColumn = True
If keepColumn Then
currentColumn = currentColumn + 1
Else
ActiveSheet.Columns(currentColumn).Delete
End If
If (ActiveSheet.UsedRange.Address = "$A$1") And (ActiveSheet.Range("$A$1").Text = "") Then Exit Sub
Wend
arrColOrder = Array("Source2", "LTO", "STO", "Last Detected", "First Detected", "Updated Last Detected Date", _
"Key - IP-QID-Port", "IP", "ComputerName", "OS", "QID", "PORT", "AppCat", "Application_Name", _
"SERVERPURPOSE", "Remediation Approach", "CxO Planned Date", "GITRM confirmed remediation", "Comments", _
"NOTE")
counter = 1
Application.ScreenUpdating = False
For ndx = LBound(arrColOrder) To UBound(arrColOrder)
Set Found = Rows("1:1").Find(arrColOrder(ndx), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not Found Is Nothing Then
If Found.Column <> counter Then
Found.EntireColumn.Cut
Columns(counter).Insert Shift:=xlToRight
Application.CutCopyMode = False
End If
counter = counter + 1
End If
Next ndx
Application.ScreenUpdating = True
Range("A1").Select
Worksheets.Add(After:=Worksheets(Sheets.Count)).Name = "temp"
Sheets("Backlog Reclassified").Select
ActiveSheet.ListObjects("cht").Range.Select
Selection.Copy
Sheets("temp").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Set Rng = Range(Range("A1"), Range("A1").SpecialCells(xlLastCell))
Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Rng, , xlYes)
tbl.Name = "temp"
tbl.TableStyle = "TableStyleLight8"
Range("A1").Select
currentColumn = 1
While currentColumn <= ActiveSheet.UsedRange.Columns.Count
columnHeading = ActiveSheet.UsedRange.Cells(1, currentColumn).Value
keepColumn = False
If columnHeading = "LTO" Then keepColumn = True
If columnHeading = "STO" Then keepColumn = True
If columnHeading = "Last Detected" Then keepColumn = True
If columnHeading = "First Detected" Then keepColumn = True
If columnHeading = "Updated Last Detected Date" Then keepColumn = True
If columnHeading = "Key - IP-QID-Port" Then keepColumn = True
If columnHeading = "IP" Then keepColumn = True
If columnHeading = "ComputerName" Then keepColumn = True
If columnHeading = "OS" Then keepColumn = True
If columnHeading = "QID" Then keepColumn = True
If columnHeading = "PORT" Then keepColumn = True
If columnHeading = "AppCat" Then keepColumn = True
If columnHeading = "Application_Name" Then keepColumn = True
If columnHeading = "SERVERPURPOSE" Then keepColumn = True
If columnHeading = "Remediation Approach" Then keepColumn = True
If columnHeading = "CxO Planned Date" Then keepColumn = True
If columnHeading = "GITRM confirmed remediation" Then keepColumn = True
If columnHeading = "Comments" Then keepColumn = True
If columnHeading = "NOTE" Then keepColumn = True
If columnHeading = "Source2" Then keepColumn = True
If keepColumn Then
currentColumn = currentColumn + 1
Else
ActiveSheet.Columns(currentColumn).Delete
End If
If (ActiveSheet.UsedRange.Address = "$A$1") And (ActiveSheet.Range("$A$1").Text = "") Then Exit Sub
Wend
arrColOrder = Array("Source2", "LTO", "STO", "Last Detected", "First Detected", "Updated Last Detected Date", _
"Key - IP-QID-Port", "IP", "ComputerName", "OS", "QID", "PORT", "AppCat", "Application_Name", _
"SERVERPURPOSE", "Remediation Approach", "CxO Planned Date", "GITRM confirmed remediation", "Comments", _
"NOTE")
counter = 1
Application.ScreenUpdating = False
For ndx = LBound(arrColOrder) To UBound(arrColOrder)
Set Found = Rows("1:1").Find(arrColOrder(ndx), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not Found Is Nothing Then
If Found.Column <> counter Then
Found.EntireColumn.Cut
Columns(counter).Insert Shift:=xlToRight
Application.CutCopyMode = False
End If
counter = counter + 1
End If
Next ndx
Application.ScreenUpdating = True
Range("A1").Select
ActiveSheet.ListObjects("temp").DataBodyRange.Select
Selection.Copy
Sheets("Combined").Select
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Sheets("temp").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Combined").Select
Range("combined[[#Headers],[Source2]]").Select
ActiveCell.FormulaR1C1 = "Source"
Rows("1:3").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Total Number of Records"
Range("B1").Select
ActiveCell.FormulaR1C1 = "=COUNTA(combined[[Source]:[Source]])"
Range("A2").Select
ActiveCell.FormulaR1C1 = "Total Number Open"
Range("B2").Select
ActiveCell.FormulaR1C1 = _
"=COUNTBLANK(combined[[GITRM confirmed remediation]:[GITRM confirmed remediation]])"
Range("A1").Select
End Sub