Modify VBA code

cobber1418 · Aug 22nd 2021

Hi KjBox , you created the below code for me previously and I would like it modified if possible. It uses Option Base 1.

I only need one Const, Post Work Manual

I need an extra WrkClss, SMOK

See code below, thanks in advance.

Code

Private Sub WorkPrograms()
'Work Programs
 Dim x, y, Cols, ContAreas, WrkClss, i As Long, ii As Long, iii As Long
 
 Const Category As String = "Standard of Work" 'NO LONGER EQUIRED*********
 Const InspType As String = "Post Work Manual" 'ONLY NEED THIS*********
 
 ContAreas = Array("SECA11", "SECA12", "SECA13", "SECA14", "SECA15", "SECA16")
 Cols = Array(1, 4, 7, 10, 13, 16, 19, 22)
 WrkClss = Array("UW", "PW", "VAC*", "MPWCAP", "MOD*", "LGC", "BES", "MPWA") 'NEED "SMOK" ADDED AFTER "MPWA"************

 x = Sheets("calculations").[a6].CurrentRegion

 ReDim y(1 To 6, 1 To 23)

 For i = 2 To UBound(x, 1)
 For ii = 1 To 6

 If x(i, 3) = ContAreas(ii) And x(i, 7) = Category And x(i, 8) = InspType Then
 For iii = 1 To 8
 If IsEmpty(y(ii, Cols(iii))) Then y(ii, Cols(iii)) = 0
 If IsEmpty(y(ii, Cols(iii) + 1)) Then y(ii, Cols(iii) + 1) = 0
  If x(i, 4) Like WrkClss(iii) Then
 If x(i, 9) = "Pass" Then
 y(ii, Cols(iii)) = y(ii, Cols(iii)) + 1
 Else
 y(ii, Cols(iii) + 1) = y(ii, Cols(iii) + 1) + 1
 End If
 End If
 Next
 End If
 Next
 Next
 With ActiveSheet
 .[h5].Resize(6, 23) = y
 .Activate
 End With
End Sub

Display More

**KjBox** · Aug 22nd 2021

Can you attach your workbook, I no longer have it on my system.

cobber1418 · Aug 22nd 2021

Hi KjBox , I tried attaching it to a workbook but I usually just use Personal so not sure if it worked.

**KjBox** · Aug 23rd 2021

Try this

Code

Option Base 1

Private Sub WorkPrograms()
'Work Programs
    Dim x, y, Cols, ContAreas, WrkClss, i As Long, ii As Long, iii As Long
 
    Const InspType As String = "Post Work Manual" 'ONLY NEED THIS ONE
 
    ContAreas = Array("SECA11", "SECA12", "SECA13", "SECA14", "SECA15", "SECA16")
    Cols = Array(1, 4, 10, 13, 16, 19, 22)
    WrkClss = Array("UW", "PW", "VAC*", "MPWCAP", "MOD*", "LGC", "BES", "MPWA", "SMOK") 
    x = Sheets("calculations").[a6].CurrentRegion

' ReDim y(1 To 5, 1 To 30)'could be number of Contractors (rows)
    ReDim y(1 To 6, 1 To 23)

    For i = 2 To UBound(x, 1)
        For ii = 1 To 6

            If x(i, 3) = ContAreas(ii) And x(i, 8) = InspType Then
                For iii = 1 To 7
                    If IsEmpty(y(ii, Cols(iii))) Then y(ii, Cols(iii)) = 0
                    If IsEmpty(y(ii, Cols(iii) + 1)) Then y(ii, Cols(iii) + 1) = 0
                    If x(i, 4) Like WrkClss(iii) Then
                        If x(i, 9) = "Pass" Then
                            y(ii, Cols(iii)) = y(ii, Cols(iii)) + 1
                        Else
                            y(ii, Cols(iii) + 1) = y(ii, Cols(iii) + 1) + 1
                        End If
                    End If
                Next
            End If
        Next
    Next
    With ActiveSheet
        .[h5].Resize(6, 23) = y 'CHANGE
        .Activate
    End With
    
End Sub

Display More

cobber1418 · Aug 23rd 2021

Hi KjBox , works perfectly. Much appreciated.

**KjBox** · Aug 23rd 2021

You're welcome

Modify VBA code

Participate now!

Share

Tags

Users Viewing This Thread