Click here to edit title

lets learn together

Download

Calibration

Posted by [email protected] on March 17, 2017 at 11:25 AM

Option Base 1

Sub Automation()

Dim data As Range

Application.DisplayAlerts = False

'Sheets("LookupData").Select

For Each Sheet In ActiveWorkbook.Worksheets

If Sheet.Name = "Summary" Then

Sheet.Delete

End If

Next

 

resp = MsgBox("Have you update severity infomation in Lookup Sheet ?", vbQuestion + vbYesNo, "Please select Appropriate")

If resp = vbYes Then

'------------

 

Sheets("LookupData").Select

Columns(4).Clear

Cells.Find(What:="Severity", After:=[a1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).EntireColumn.Copy Destination:=Columns(4)

ActiveSheet.Range("$D$1:$D$200").RemoveDuplicates Columns:=1, Header:=xlYes

'-----------------

Set data = Sheets("LookupData").Range("A1").CurrentRegion

Sheets("Master").Select

Cells.Clear

Master = ThisWorkbook.Name

With Application.FileDialog(msoFileDialogOpen)

.AllowMultiSelect = False

.Title = "Select the Callibration Template File"

If .Show = False Then

MsgBox "You have not selected Required file Hence exiting ; Please re-run the macro ", vbCritical, "Thomson Reuters"

Exit Sub

End If

xx = .SelectedItems(1)

Workbooks.Open (xx)

slave = ActiveWorkbook.Name

For Each Sheet In ActiveWorkbook.Worksheets

On Error Resume Next

If Sheet.Name = "Main" Then

Sheet.Select

Cells.Copy

Windows(Master).Activate

Sheets("Master").Activate

Range("A1").PasteSpecial xlPasteValues

Range("A1").PasteSpecial xlPasteFormats

Cells.Find(What:="Coding Sample", After:=[a1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).Select

ActiveCell.EntireColumn.SpecialCells(xlCellTypeBlanks).EntireRow.Delete

totrow = WorksheetFunction.CountA(ActiveCell.EntireColumn)

End If

Next Sheet

End With

Cells.EntireColumn.Hidden = False

Call Bordering

Call Clearformat

'

reqcolumn = Cells.Find("Coding Sample", After:=[a1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column

lastcolumn = Range("Xfd1").End(xlToLeft).Column

Range(Cells(1, reqcolumn + 2), Cells(1, lastcolumn)).Copy

Cells(1, lastcolumn).Offset(0, 1).PasteSpecial xlPasteValues

Cells(1, lastcolumn).Offset(0, 1).PasteSpecial xlPasteFormats

Worksheets.Add After:=Sheets(Worksheets.Count): ActiveSheet.Name = "Summary"

Range("A2").PasteSpecial Transpose:=True

Range("A1").Value = "Manager Names"

 

Sheets("Master").Select

Newstart = lastcolumn + 1

noofrow = WorksheetFunction.CountA(Columns(reqcolumn))

'codsamp = Cells.Find(what:="Coding Sample", After:=[a1], LookIn:=xlValues, Lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlNext).Column

orgcod = Cells.Find(What:="Original Coding", After:=[a1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column

'---------------------------- Replacements-----------------------------------------

Cells.Replace What:="yes", Replacement:="Yes"

Cells.Replace What:="YES", Replacement:="Yes"

Cells.Replace What:="yes ", Replacement:="Yes"

Cells.Replace What:="Yes ", Replacement:="Yes"

Cells.Replace What:=" Yes ", Replacement:="Yes"

Cells.Replace What:=" yes ", Replacement:="Yes"

totalyes = WorksheetFunction.CountIf(Cells, "Yes")

TotalMgr = lastcolumn - orgcod

For c = 1 To TotalMgr

For i = 2 To noofrow

Cells(i, Newstart).Select

test = Abs(StrComp(Cells(i, orgcod).Value, Cells(i, orgcod + c), vbTextCompare))

If test = 0 Then

Cells(i, Newstart).Value = 1

Else

Cells(i, Newstart).Value = 0

End If

Next

Newstart = Newstart + 1

Next

copycol = Cells.Find("Code", After:=[a1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column

Range(Cells(1, copycol), Cells(noofrow, copycol)).Copy

Worksheets.Add After:=Sheets(Worksheets.Count)

ActiveSheet.Name = "Temp"

Range("a1").PasteSpecial xlPasteValues

Selection.SpecialCells(xlCellTypeBlanks).Select

Selection.FormulaR1C1 = "=R[-1]C"

Range("a1").CurrentRegion.Copy: Sheets("Master").Select

Range("Xfd1").End(xlToLeft).Offset(0, 1).PasteSpecial xlPasteValues

Sheets("Temp").Delete

Range("Xfd1").End(xlToLeft).Offset(0, 1).Select: ActiveCell.Value = "Severity"

col = ActiveCell.Column - 1

For x = 2 To noofrow

Cells(x, col + 1).Value = Application.WorksheetFunction.VLookup(Cells(x, col), data, 2, 0)

Next x

Windows(slave).Close savechanges:=False

Call Bordering

Call Percentagecalculate

Call NewReport

MsgBox " Thank you for using this Tool The Report has been generated", vbInformation, "Thomson Reuters"

Else

MsgBox "Please update the lookup sheet first and re-run the macro", vbCritical, "Thomson Reuters"

End If

 

End Sub

 

Sub Clearformat()

sc = Range("Xfd1").End(xlToLeft).Column + 1

Range(Cells(1, sc), Cells(1048576, 16384)).ClearFormats

End Sub

 

Sub Percentagecalculate()

On Error Resume Next

Sheets("Summary").Select

lr = Range("A1048576").End(xlUp).Row

tot = WorksheetFunction.CountA(Sheets("LookupData").Range("D:D"))

ReDim Sever(tot)

 

For v = 2 To tot

Sever(v) = Sheets("LookupData").Range("D" & v).Value

Next

 

Sheets("Summary").Cells(1, 2).Value = "OverAll": Sheets("Summary").Cells(1, 3).Value = Sever(2)

Sheets("Summary").Cells(1, 4).Value = Sever(3): Sheets("Summary").Cells(1, 5).Value = Sever(4)

Sheets("Summary").Cells(1, 6).Value = Sever(5): Sheets("Summary").Cells(1, 7).Value = Sever(6)

 

Dim severity As Range

Set severity = Sheets("Master").Range("1:1").Find(What:="Severity", After:=[a1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).EntireColumn

 

 

For i = 2 To lr

x = Sheets("Summary").Range("A" & i).Value

Set myrange = Sheets("Master").Range("1:1").Find(What:=x, After:=[a1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).EntireColumn

x = WorksheetFunction.Count(myrange)

y = WorksheetFunction.Sum(myrange)

n = y / x

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

Range("B" & i).NumberFormat = "0.0%"

xx = WorksheetFunction.CountIf(severity, Sever(2))

yy = WorksheetFunction.SumIf(severity, Sever(2), myrange)

nn = yy / xx

Range("C" & i).Value = nn

Range("c" & i).NumberFormat = "0.0%"

xxx = WorksheetFunction.CountIf(severity, Sever(3))

yyy = WorksheetFunction.SumIf(severity, Sever(3), myrange)

nnn = yyy / xxx

Range("d" & i).Value = nnn

Range("d" & i).NumberFormat = "0.0%"

xxxx = WorksheetFunction.CountIf(severity, Sever(4))

yyyy = WorksheetFunction.SumIf(severity, Sever(4), myrange)

nnnn = yyyy / xxxx

Range("e" & i).Value = nnnn

Range("e" & i).NumberFormat = "0.0%"

' 4th fifth

xxxxx = WorksheetFunction.CountIf(severity, Sever(5))

yyyyy = WorksheetFunction.SumIf(severity, Sever(5), myrange)

nnnnn = yyyyy / xxxxx

Range("f" & i).Value = nnnnn

Range("f" & i).NumberFormat = "0.0%"

xxxxxx = WorksheetFunction.CountIf(severity, Sever(6))

yyyyyy = WorksheetFunction.SumIf(severity, Sever(6), myrange)

nnnnnn = yyyyyy / xxxxxx

Range("g" & i).Value = nnnnnn

Range("g" & i).NumberFormat = "0.0%"

'

Next i

 

Call Bordering

 

 

End Sub

Sub NewReport()

Dim Wb1 As Workbook

Dim Wb2 As Workbook

Dim dateStr As String

Dim myDate As Date

 

With Application

.ScreenUpdating = False

.DisplayAlerts = False

.EnableEvents = False

End With

 

Set Wb1 = ActiveWorkbook

 

myDate = Date

 

dateStr = Format(myDate, "MM-DD-YY")

 

Set Wb2 = Application.Workbooks.Add(1)

Wb1.Sheets(Array(Wb1.Sheets(2).Name, Wb1.Sheets(4).Name)).Copy Before:=Wb2.Sheets(1)

Wb2.Sheets(Wb2.Sheets.Count).Delete

 

Dim bFileSaveAs As Boolean

bFileSaveAs = Application.Dialogs(xlDialogSaveAs).Show

If Not bFileSaveAs Then MsgBox "User cancelled", vbCritical

 

' Wb2.SaveAs Filename:="U:\For Prince\02. Adhoc Work\11. Hari\Callibration Generated\" & " " & "Callibration Sheet " & dateStr ', FileFormat:=51

'

' Wb2.Close

With Application

.ScreenUpdating = True

.DisplayAlerts = True

.EnableEvents = True

End With

End Sub

 

Sub Bordering()

 

With Cells

.Borders(xlDiagonalDown).LineStyle = xlNone

.Borders(xlDiagonalUp).LineStyle = xlNone

.Borders(xlEdgeLeft).LineStyle = xlNone

.Borders(xlEdgeTop).LineStyle = xlNone

.Borders(xlEdgeBottom).LineStyle = xlNone

.Borders(xlEdgeRight).LineStyle = xlNone

.Borders(xlInsideVertical).LineStyle = xlNone

.Borders(xlInsideHorizontal).LineStyle = xlNone

End With

With Range("A1").CurrentRegion

.Borders(xlEdgeLeft).LineStyle = xlContinuous

.Borders(xlEdgeTop).LineStyle = xlContinuous

.Borders(xlEdgeBottom).LineStyle = xlContinuous

.Borders(xlEdgeRight).LineStyle = xlContinuous

.Borders(xlInsideVertical).LineStyle = xlContinuous

.Borders(xlInsideHorizontal).LineStyle = xlContinuous

End With

Cells.Interior.Pattern = xlNone

Cells.Font.Bold = False

LC = Range("XFD1").End(xlToLeft).Column

Range(Cells(1, 1), Cells(1, LC)).Interior.ColorIndex = 36

Range("A1").CurrentRegion.EntireColumn.AutoFit

End Sub

 

 

 

Categories: None

Post a Comment

Oops!

Oops, you forgot something.

Oops!

The words you entered did not match the given text. Please try again.

Already a member? Sign In

0 Comments