'Macro: Calculate first time pass rate % of PTR Test Rig
'Author: G R Withey
'Date: Sept-Jan 2008-2009
Option Explicit
'Checks if a worksheet exists
Function wsExists(wksName As String) As Boolean
On Error Resume Next
wsExists = CBool(Len(Worksheets(wksName).Name) > 0)
On Error GoTo 0 'After On Error check resume checking as normal
End Function
'Calculates sheet (3)
Sub CalcDataSheet()
Dim TotalRows As Long
Dim C As Integer
Dim HeadingArray
Dim Ro As Long
On Error Resume Next
With Application
.DisplayAlerts = False 'Smother operation improving speed
.ScreenUpdating = False
.Calculation = xlCalculationManual
Application.Worksheets(3).Activate
TotalRows = Cells(Rows.Count, 1).End(xlUp).Row 'Making total rows variable = total rows in worksheet
With ThisWorkbook.Worksheets(3)
.Range(.Cells(2, 11), .Cells(TotalRows, 11)).FormulaR1C1 = "=IF(RC[-3]=0,0,IF(R[1]C[-3]=RC[-3],0,1))"
.Range(.Cells(2, 12), .Cells(TotalRows, 12)).FormulaR1C1 = "=IF(RC[-10]=""Production"",1,0)"
.Range(.Cells(2, 13), .Cells(TotalRows, 13)).FormulaR1C1 = "=IF(RC[-12]=""Verification"",1,0)" 'Perform Calculations
.Range(.Cells(2, 14), .Cells(TotalRows, 14)).FormulaR1C1 = "=IF(RC[-8]=""** TEST ABORTED **"",1,0)"
.Range(.Cells(2, 15), .Cells(TotalRows, 15)).FormulaR1C1 = "=IF(R[1]C[-14]=""Incomplete"",1,0)"
.Range(.Cells(2, 16), .Cells(TotalRows, 16)).FormulaR1C1 = "=IF(RC[-10]=""** TEST FAILED **"",1,0)"
.Range(.Cells(2, 17), .Cells(TotalRows, 17)).FormulaR1C1 = "=IF(RC[-11]=""** TEST PASSED **"",1,0)"
.Range(.Cells(2, 18), .Cells(TotalRows, 18)).FormulaR1C1 = "=RC[-7]*RC[-6]*RC[-1]"
.Range(.Cells(2, 19), .Cells(TotalRows, 19)).FormulaR1C1 = "=RC[-8]*RC[-7]*RC[-3]"
End With
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
If ThisWorkbook.Worksheets(3).Cells(1, 1) <> "Status" Then Rows("1:1").Select: Selection.Insert Shift:=xlDown ' If status in A1 heading already exsists
HeadingArray = Array("Status", "Test Type", "User ID", "Probe", "Date", "Text Note", "Failure Reason", _
"Serial Number", "Start Time", "Rig Number", "First Test", "Production", "Verification", _
"Test Aborted", "Test Incomplete", "Test Failed", "Test Passed", "FTF", "FTP") 'Adding Header Row using Array
ThisWorkbook.Worksheets(3).Cells(1, 1).Resize(1, 1 + UBound(HeadingArray)).Value = HeadingArray
ThisWorkbook.Worksheets(3).Cells.Select
Selection.Sort Key1:=Range("E1"), Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'^Sorting Dates into Acending order
ThisWorkbook.Worksheets(1).Activate
Call SortDataToMonths
End Sub
'Sorts data on sheet (3) "Data" into named month sheets
Sub SortDataToMonths()
Dim ShtData As Worksheet
Dim Rng As Range
Dim Cl As Range
Dim Sht As String
On Error GoTo ErrorHandlingSortDataToMonths
With Application
.DisplayAlerts = False
.ScreenUpdating = False 'Speed up operation(Chnaging settings)
.Calculation = xlCalculationManual
Set ShtData = Sheet3 ' make Sheet 3 an object
With ShtData
Set Rng = .Range(.Cells(2, 5), .Cells(.Rows.Count, 5).End(xlUp)) 'defining the range (exsisting no of rows)
For Each Cl In Rng
If IsDate(Cl.Value) Then Sht = MonthName(Month(Cl.Value)) & "_" & (Year(Cl.Value)) 'If cell has_
If Not wsExists(Sht) Then '_Date Var sht = cell' value
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Sht
'add header row 'If ws doesnt exist add new sheet + name it the cells value
.Cells(1, 1).EntireRow.Copy Sheets(Sht).Cells(1, 1) 'Then add the row of data
End If
If Not IsEmpty(Cl) Then Cl.EntireRow.Copy Sheets(Sht).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next Cl '^Otherwise if sheet exists copy row to the sheet
.Select 'check if cell is empty then select next cell
End With
Worksheets(1).Select
.DisplayAlerts = True
.ScreenUpdating = True 'Ending speed enhancing settings
.Calculation = xlCalculationAutomatic
End With
ErrorHandlingSortDataToMonths:
Dim ErrorSht As Worksheet
Dim Msg As String
Select Case Err
Case 1004: 'Data may not have been imported to data sheet
Msg = "An Error Has Occured" & vbNewLine
Msg = Msg & "Check that there is data in sheet 3 (Data) and retry" 'Error Message produced if sheet3 is empty
MsgBox Msg
For Each ErrorSht In ThisWorkbook.Worksheets
If ErrorSht.Index > 3 Then ErrorSht.Delete 'deletes any empty sheets created by the macro
Next ErrorSht
Worksheets(1).Select
Exit Sub
Case Else
End Select
Call AddFormulas
End Sub
LinkBack URL
About LinkBacks
Register To Reply
Re: Multidimensional array
Bookmarks