Log in

View Full Version : Code to update a KPI based on a worksheet


nathandavies
09-07-2017, 11:43 AM
Hi All,
I have been used a workbook for a few months but i need to make a change to the code. at the minute the code looks at the first 2 letters of project number XX12345 to create a loading and sub-loading table on a new worksheet, i'm wanting to change this to look at the text in "Column C".

I have tried to change the code myself (code located in Module 5_NEW) but it doesn't seem to work and i'm not sure why. i have included my original code (module5_OLD)

If someone would be able to help me correct my mistake or point me in the right direction.

Cheers
Nathan.20281
nathandavies
09-08-2017, 12:54 AM
Hi All, I have done some more testing this morning and have found where the problem is, I have highlighted the problem in RED on the first copy of the code, the code that is currently in is looking for the first two upper case letters of the project number (ie. XX) but I no longer require that, i need to look at the first 3 letters in a separate cell (Column C). could someone please help with the re-right of the code? or point me in the right direction as to what i need to change.


Private Function GetMonthLoad(strFramework As String, strMonthYear As String, blnThisFrameworkOnly As Boolean, strDept As String) As IntegerDim blnActive As Boolean
Dim lngR As Long
Dim intT As Integer
Dim intC As Integer
Dim strJobNo As String
Dim JobComCol As String
Dim strCFAT As String
Dim blnIsThisFramework As Boolean
intT = 0
For lngR = 3 To MaxRows
If Len(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, JobComCol)) >= Len(strProjectType) Then
' If the correct project type
strJobNo = Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, JobComCol)

blnIsThisFramework = False

If strFramework = "HCS" Then
If JobComCol = "HCS" Then blnIsThisFramework = True
End If

If strFramework = "ENG" Then
If JobComCol = "ENG" Then blnIsThisFramework = True
End If

If strFramework = "OBS" Then
If JobComCol = "OBS" Then blnIsThisFramework = True
End If

If strFramework = "SCH" Then
If JobComCol = "SCH" Then blnIsThisFramework = True
End If

If strFramework = "JCB" Then
If JobComCol = "JCB" Then blnIsThisFramework = True
End If

If strFramework = "OTHER" Then
End If


If blnThisFrameworkOnly = False Then blnIsThisFramework = True

If InStr(1, strFramework, "all") Then blnIsThisFramework = True

If blnIsThisFramework Then
strCFAT = Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, CFATCol)
blnActive = False
If strCFAT <> "" And UCase(strCFAT) <> "N/A" Then

blnActive = CDate("01/" & Format(strMonthYear, "mm/yyyy")) < CDate(Format(strCFAT, "dd/mm/yyyy")) And IsTaskCompleted(lngR, CFATCol) <= 2
End If
Select Case strDept
Case "E" ' Engineering
' Is it a panel
If InStr(1, Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TypeCol), "M") > 0 _
Or InStr(1, Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TypeCol), "C") > 0 _
Or InStr(1, Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TypeCol), "S") > 0 _
Or InStr(1, Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TypeCol), "T") > 0 _
Then
If blnActive Then
intT = intT + 1
End If
End If

Case "P" ' Production
' Check if there is a date, if not use the delivery date
If Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, DespatchCol) <> "" Then
If Format(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, DespatchCol), "mm/yyyy") = Format(strMonthYear, "mm/yyyy") Then
On Error Resume Next
intC = CInt(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TiersCol))
intT = intT + intC
End If
Else ' delivery date? if not guess 8 week from today...it's better than nothing!
If Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, DeliveryCol) <> "" Then
If Format(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, DeliveryCol), "mm/yyyy") = Format(strMonthYear, "mm/yyyy") Then
On Error Resume Next
intC = CInt(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TiersCol))
intT = intT + intC
End If
Else
If Format(DateAdd("ww", 8, Now()), "mm/yyyy") = Format(strMonthYear, "mm/yyyy") Then
On Error Resume Next
intC = CInt(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TiersCol))
intT = intT + intC
End If
End If
End If

Case "S" ' Software
' Is it Systems Integration
If InStr(1, Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TypeCol), "P") > 0 _
Or (InStr(1, Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TypeCol), "X") > 0 And InStr(1, LCase(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, JobNameCol)), "plc") > 0) _
Or (InStr(1, Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TypeCol), "X") > 0 And InStr(1, LCase(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, JobNameCol)), "hmi") > 0) _
Or (InStr(1, Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TypeCol), "X") > 0 And InStr(1, LCase(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, JobNameCol)), "scada") > 0) _
Or (InStr(1, Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TypeCol), "X") > 0 And InStr(1, LCase(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, JobNameCol)), "software") > 0) _
Then
If blnActive Then
intT = intT + 1
End If
End If
End Select
End If
End If
Next lngR
GetMonthLoad = intT
End Function

I have highlighted the error in red, i'm not sure how to change this line of code to look for the text detail which would be located in Column C. I have put a copy of my original code as well for an help.



Sub FrameworkUpdateLoading(strFramework As String)
Dim intM As Integer
Dim intT As Integer
Dim intMT As Integer
Dim intJ As Integer
Dim lngR As Long
Dim lngPrg As Long
Dim lngBox As Long
Dim datD As Date
Dim strMY As String
Dim JobComCol As String


'On Error GoTo HandleError
Application.StatusBar = "Updating Loading page...please wait..."
GetMaxRows
datD = CDate("01/" & Format(Now(), "mm/yyyy"))
datD = DateAdd("m", -1, datD)
Excel.Workbooks("NEW WIP").Worksheets("SubLoading").Cells(6, 3) = strFramework & " Engineering Projects"
Excel.Workbooks("NEW WIP").Worksheets("SubLoading").Cells(9, 3) = strFramework & " Production Tiers"
Excel.Workbooks("NEW WIP").Worksheets("SubLoading").Cells(12, 3) = strFramework & " Systems Integration Projects"
Excel.Workbooks("NEW WIP").Worksheets("SubLoading").Cells(17, 3) = "% of which is " & strFramework
Excel.Workbooks("NEW WIP").Worksheets("SubLoading").Cells(20, 3) = "% of which is " & strFramework
Excel.Workbooks("NEW WIP").Worksheets("SubLoading").Cells(23, 3) = "% of which is " & strFramework


For intM = 1 To 6
strMY = "01/" & Format(DateAdd("m", intM, datD), "mm/yyyy")
Excel.Workbooks("NEW WIP").Worksheets("SubLoading").Cells(4, 3 + intM) = Format(strMY, "mmm-yyyy")
intMT = 0
intJ = 4

intJ = intJ + 1
Excel.Workbooks("NEW WIP").Worksheets("SubLoading").Cells(intJ, 3 + intM) = GetMonthLoad(strFramework, strMY, False, "E")
intMT = intMT + intT

intJ = intJ + 1
Excel.Workbooks("NEW WIP").Worksheets("SubLoading").Cells(intJ, 3 + intM) = GetMonthLoad(strFramework, strMY, True, "E")
intMT = intMT + intT


intJ = intJ + 2
Excel.Workbooks("NEW WIP").Worksheets("SubLoading").Cells(intJ, 3 + intM) = GetMonthLoad(strFramework, strMY, False, "P")
intMT = intMT + intT

intJ = intJ + 1
Excel.Workbooks("NEW WIP").Worksheets("SubLoading").Cells(intJ, 3 + intM) = GetMonthLoad(strFramework, strMY, True, "P")
intMT = intMT + intT


intJ = intJ + 2
Excel.Workbooks("NEW WIP").Worksheets("SubLoading").Cells(intJ, 3 + intM) = GetMonthLoad(strFramework, strMY, False, "S")
intMT = intMT + intT

intJ = intJ + 1
Excel.Workbooks("NEW WIP").Worksheets("SubLoading").Cells(intJ, 3 + intM) = GetMonthLoad(strFramework, strMY, True, "S")
intMT = intMT + intT


Next intM
Exit Sub


GoTo OverError


HandleError:
MsgBox "The following error has been raised:" & vbCrLf & Err.Number & vbCrLf & Err.Description, vbExclamation, "Error"
Resume Next
OverError:
Application.StatusBar = "Done"
End Sub


Private Function GetMonthLoad(strFramework As String, strMonthYear As String, blnThisFrameworkOnly As Boolean, strDept As String) As Integer
Dim blnActive As Boolean
Dim lngR As Long
Dim intT As Integer
Dim intC As Integer
Dim strJobNo As String
Dim JobComCol As String
Dim strCFAT As String
Dim blnIsThisFramework As Boolean
intT = 0
For lngR = 3 To MaxRows
If Len(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, JobNoCol)) >= Len(strProjectType) Then
' If the correct project type
strJobNo = Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, JobNoCol)

blnIsThisFramework = False

If strFramework = "HCS" Then
If JobNoCol = "HCS" Then blnIsThisFramework = True
End If

If strFramework = "ENG" Then
If JobNoCol = "ENG" Then blnIsThisFramework = True
End If

If strFramework = "OBS" Then
If JobNoCol = "OBS" Then blnIsThisFramework = True
End If

If strFramework = "SCH" Then
If JobNoCol = "SCH" Then blnIsThisFramework = True
End If

If strFramework = "JCB" Then
If JobNoCol = "JCB" Then blnIsThisFramework = True
End If

If strFramework = "OTHER" Then
End If


If blnThisFrameworkOnly = False Then blnIsThisFramework = True

If InStr(1, strFramework, "all") Then blnIsThisFramework = True

If blnIsThisFramework Then
strCFAT = Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, CFATCol)
blnActive = False
If strCFAT <> "" And UCase(strCFAT) <> "N/A" Then

blnActive = CDate("01/" & Format(strMonthYear, "mm/yyyy")) < CDate(Format(strCFAT, "dd/mm/yyyy")) And IsTaskCompleted(lngR, CFATCol) <= 2
End If
Select Case strDept
Case "E" ' Engineering
' Is it a panel
If InStr(1, Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TypeCol), "M") > 0 _
Or InStr(1, Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TypeCol), "C") > 0 _
Or InStr(1, Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TypeCol), "S") > 0 _
Or InStr(1, Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TypeCol), "T") > 0 _
Then
If blnActive Then
intT = intT + 1
End If
End If

Case "P" ' Production
' Check if there is a date, if not use the delivery date
If Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, DespatchCol) <> "" Then
If Format(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, DespatchCol), "mm/yyyy") = Format(strMonthYear, "mm/yyyy") Then
On Error Resume Next
intC = CInt(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TiersCol))
intT = intT + intC
End If
Else ' delivery date? if not guess 8 week from today...it's better than nothing!
If Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, DeliveryCol) <> "" Then
If Format(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, DeliveryCol), "mm/yyyy") = Format(strMonthYear, "mm/yyyy") Then
On Error Resume Next
intC = CInt(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TiersCol))
intT = intT + intC
End If
Else
If Format(DateAdd("ww", 8, Now()), "mm/yyyy") = Format(strMonthYear, "mm/yyyy") Then
On Error Resume Next
intC = CInt(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TiersCol))
intT = intT + intC
End If
End If
End If

Case "S" ' Software
' Is it Systems Integration
If InStr(1, Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TypeCol), "P") > 0 _
Or (InStr(1, Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TypeCol), "X") > 0 And InStr(1, LCase(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, JobNameCol)), "plc") > 0) _
Or (InStr(1, Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TypeCol), "X") > 0 And InStr(1, LCase(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, JobNameCol)), "hmi") > 0) _
Or (InStr(1, Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TypeCol), "X") > 0 And InStr(1, LCase(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, JobNameCol)), "scada") > 0) _
Or (InStr(1, Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, TypeCol), "X") > 0 And InStr(1, LCase(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, JobNameCol)), "software") > 0) _
Then
If blnActive Then
intT = intT + 1
End If
End If
End Select
End If
End If
Next lngR
GetMonthLoad = intT
End Function
nathandavies
09-08-2017, 01:00 AM
The Code has not highlight so this is the error line


If Len(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, JobComCol)) >= Len(strProjectType) Then

Original


If Len(Excel.Workbooks("NEW WIP").Worksheets("WIP").Cells(lngR, JobNoCol)) >= Len(strProjectType) Then
mdmackillop
09-08-2017, 04:15 AM
The code in the workbook you posted doesn't compile eg WasDoneLate takes 4 parameters, your code provides 2. I can't get as far as the error you describe.

WasDoneLate(lngM, lngC)
nathandavies
09-10-2017, 10:16 AM
I cannot get it to work either, it has been working previously!

i'm not sure what i need to do to get past this either.
nathandavies
09-18-2017, 07:35 AM
mdmackillop (http://www.vbaexpress.com/forum/member.php?87-mdmackillop), i have managed to find the errors and now the code complies.

please see the attached updated workbook.