This is the code
This problem is becoming urgent as I have an imminent deadlien - I didn't
think it would be hard to solve but since it's not happening it's now
becoming urgent.
Any help greatly appreciated!
Matt
Option Explicit
Function OLEObjectExists(sName As String) 'this function checks if an OLE
object name exists
Dim vtop
On Error Resume Next
vtop = ActiveSheet.OLEObjects(sName).top
If Err = 0 Then
OLEObjectExists = True
Else
OLEObjectExists = False
Err.Clear
End If
End Function
Sub PopulateA10PMProductRange()
Application.ScreenUpdating = False
Application.Cursor = xlWait
'dimension variables
Dim vaProducts, vaProductLevel As Variant 'create arrays
Dim i, j As Integer 'i for row, j for column
Dim cellUnder As Range 'this variables contains the "working cell" when
creating the checkboxes
Dim cb, lbl As OLEObject
Dim ws As Worksheet
Dim MyChar
Dim intLeft, intSpacing, intLeftLocation As Integer
'assign values to variables
Set ws = Worksheets("A10Checklist")
ws.Range("A1").Activate
MyChar = Chr(252)
intLeft = 280
intSpacing = 50
'status bar message (must come after 'activate' call above)
Application.DisplayStatusBar = True 'make statusbar is visible if not
already
'set status bar message
Application.StatusBar = "Updating gate products..."
'assign the values of named ranges to arrays - easier & faster than
working with the named ranges directly
vaProducts = Worksheets("Data-PMProducts-MinimumSets"). _
Range("projectrange_ProductSets").Value 'this array/range will be
used to determine what sort of checkboxes to show based on this project's
minimum PM Product Set
vaProductLevel = Worksheets("Data-PMProducts-MinimumSets"). _
Range("apprange_PMProducts_Level").Value 'this array/range is used
to determine what type of product the text we are working with is eg.0=gate
names,1=heading,2=product,3=working product
'loop thru vaProducts array i.e. loop thru project's Minimum PM Product
set range (which is dyanmically determined based on user's lifecycle and
category selection)
For i = 1 To UBound(vaProducts, 1) 'rows are in the first dimension of
the array
'only display gate products
If vaProductLevel(i, 1) = 2 Then 'we have a gate product
For j = 1 To UBound(vaProducts, 2) 'columns are in the second
dimension of the array
'so we are effectively looping first thru rows and then thru each
row's column (if it is a gate product)
'locate the actual cell where we need to 'work'
Set cellUnder =
Worksheets("A10Checklist").Range("anchorpoint_A10PMProducts") _
.Offset(i - 1, j + 1)
If UCase(vaProducts(i, j)) = "TRUE" Then 'we have a required
gate product so display a non-clickable checkbox
'create an unclickable checkbox (an OLE label object with a
Wingdings checkbox character as it's caption)
If Not OLEObjectExists("lbl_r" & i & "c" & j) Then 'only
create checkbox if it doesn't alreay exist
'first delete any unrequired, clickable checkboxes in
this matrix location
If OLEObjectExists("cb_r" & i & "c" & j) Then
ws.OLEObjects("cb_r" & i & "c" & j).Delete
End If
'set properties of new label-checkbox
intLeftLocation = (intLeft - intSpacing) + intSpacing *
(j) 'use set spacing variables
Set lbl = ws.OLEObjects.Add(ClassType:="Forms.Label.1",
_
Left:=intLeftLocation, _
top:=cellUnder.top + 4, _
Width:="10.5", _
Height:="10.5", _
DisplayAsIcon:=False)
With lbl
.Placement = xlMove ' This lets each check box stay
with its row during sorts. NEEDED???
With .Object
.Caption = MyChar
'.BackColor = &H80000005
'.BackStyle = fmBackStyleTransparent
'.Font.Size = "12"
'.ForeColor = &HFF&
.Font.Name = "Wingdings"
'.Name = "lbl_r" & i & "c" & j
'DoEvents
'.Font.Bold = True
End With
.Name = "lbl_r" & i & "c" & j 'name the label with
it's array row and column number
End With
End If
ElseIf UCase(vaProducts(i, j)) = "FALSE" Then 'display a
clickable checkbox.
'create clickable checkbox
If Not OLEObjectExists("cb_r" & i & "c" & j) Then 'only
create checkbox if it doesn't alreay exist
'if there is no checkbox it's likely there is
label-checkbox so delete it first
If OLEObjectExists("lbl_r" & i & "c" & j) Then 'only
delete label-checkbox if it exists
ws.OLEObjects("lbl_r" & i & "c" & j).Delete
End If
'create properties of checkbox
intLeftLocation = (intLeft - intSpacing) + intSpacing *
(j)
'set properties of checkbox
Set cb =
ws.OLEObjects.Add(ClassType:="Forms.CheckBox.1", _
Left:=intLeftLocation, _
top:=cellUnder.top + 4, _
Width:="10.5", _
Height:="10.5", _
DisplayAsIcon:=False)
With cb 'add other info
.Name = "cb_r" & i & "c" & j 'name the checkbox with
it's row and column number
.Placement = xlMove ' This lets each check box stay
with its row during sorts. NEEDED???
With .Object
.BackColor = &H80000005
.BackStyle = fmBackStyleTransparent
.Caption = ""
End With
End With
End If
Else 'it's not True or False so enforce that there is no object
there by deleting any
If OLEObjectExists("cb_r" & i & "c" & j) Then
ws.OLEObjects("cb_r" & i & "c" & j).Delete
End If
If OLEObjectExists("lbl_r" & i & "c" & j) Then
ws.OLEObjects("lbl_r" & i & "c" & j).Delete
End If
End If ' end if of "if vaProducts(i, j) = true or false"
statement
Next j
End If
Next i
DoEvents
Application.ScreenUpdating = True
Application.StatusBar = False 'give control of the statusbar back to the
programme
Application.Cursor = xlDefault
End Sub
