Loop To Add Check Boxes Based on Condition?

[eryksd]

Trying to add Check Boxes based on whether the cell in Column C is larger than 0, and less than 200,001.

Added two (TRUE/FALSE) example check boxes in column S, to show what I am trying to achieve, in the picture below.
(Note: they are not formatted correctly, plus I couldn't delete check boxes for the 0 values in Column C).

When I run the script, it's extremely slow, it seems to partially work (I've always stopped it after about 10 minutes). Any suggestions?

Picture:

Current Code:

Sub AddCheckBoxes()


Dim cb As CheckBox
Dim myRange As Range, cel As Range
Dim wks As Worksheet
Dim LastRow As Long, i As Long
Dim MyLeft As Double
Dim MyTop As Double
Dim MyHeight As Double
Dim MyWidth As Double


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Set wks = Sheets("Prof Pro") 'adjust sheet to your needs
wks.Activate


LastRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row 'Find the last row


Set myRange = wks.Range(Cells(2, 19), Cells(LastRow, 19)) ' adjust range to your needs


For i = 2 To LastRow


  If wks.Cells(i, 3).Value > 0 And wks.Cells(i, 3).Value < 200001 Then
  
        '-
        MyLeft = Cells(i, "S").Left
        MyTop = Cells(i, "S").Top
        MyHeight = Cells(i, "S").Height
        MyWidth = MyHeight = Cells(i, "S").Width
        '-
        ActiveSheet.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight).Select
            With Selection
                .Caption = ""
                '.Value = xlOff
                .LinkedCell = "S" & i
                '.Display3DShading = False
            End With
    
  End If
  
Next


Application.StatusBar = ""
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


End Sub

Any help would be greatly appreciated!

 

[Rhodie72]

I'm having a look at it now...

 

[Rhodie72]

Trying to add Check Boxes based on whether the cell in Column C is larger than 0, and less than 200,001.

Added two (TRUE/FALSE) example check boxes in column S, to show what I am trying to achieve, in the picture below.
(Note: they are not formatted correctly, plus I couldn't delete check boxes for the 0 values in Column C).

When I run the script, it's extremely slow, it seems to partially work (I've always stopped it after about 10 minutes). Any suggestions?

Picture:

Current Code:

Sub AddCheckBoxes()


Dim cb As CheckBox
Dim myRange As Range, cel As Range
Dim wks As Worksheet
Dim LastRow As Long, i As Long
Dim MyLeft As Double
Dim MyTop As Double
Dim MyHeight As Double
Dim MyWidth As Double


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Set wks = Sheets("Prof Pro") 'adjust sheet to your needs
wks.Activate


LastRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row 'Find the last row


Set myRange = wks.Range(Cells(2, 19), Cells(LastRow, 19)) ' adjust range to your needs


For i = 2 To LastRow


  If wks.Cells(i, 3).Value > 0 And wks.Cells(i, 3).Value < 200001 Then
  
        '-
        MyLeft = Cells(i, "S").Left
        MyTop = Cells(i, "S").Top
        MyHeight = Cells(i, "S").Height
        MyWidth = MyHeight = Cells(i, "S").Width
        '-
        ActiveSheet.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight).Select
            With Selection
                .Caption = ""
                '.Value = xlOff
                .LinkedCell = "S" & i
                '.Display3DShading = False
            End With
    
  End If
  
Next


Application.StatusBar = ""
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


End Sub

Any help would be greatly appreciated!

Well... I hope this makes it easier to understand. I've simplified some of the repetitive code.

Sub AddCheckBoxes()

Dim cb As CheckBox, myRange As Range, cel As Range, wks As Worksheet, _
    LastRow As Long, i As Long, MyLeft As Double, MyTop As Double, _
    MyHeight As Double, MyWidth As Double

With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    
        Set wks = Sheets("Prof Pro") 'adjust sheet to your needs
        wks.Activate

        LastRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row 'Find the last row

        Set myRange = wks.Range(Cells(2, 19), Cells(LastRow, 19)) ' adjust range to your needs

        For i = 2 To LastRow

          Select Case wks.Cells(i, 3).Value
            
            Case Is = 200001 > 0
                With Cells(i, "S")
                    MyLeft = .Left
                    MyTop = .Top
                    MyHeight = .Height
                    MyWidth = MyHeight '= Cells(i, "S").Width
                End With
    
                With ActiveSheet.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight)
                        .Caption = ""
                        '.Value = xlOff
                        .LinkedCell = "S" & i
                        '.Display3DShading = False
                End With
            Case Is > 200001
                Exit Sub
          End Select
        Next i

        .StatusBar = ""
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

End Sub

 

[eryksd]

Well... I hope this makes it easier to understand. I've simplified some of the repetitive code.

Sub AddCheckBoxes()

Dim cb As CheckBox, myRange As Range, cel As Range, wks As Worksheet, _
    LastRow As Long, i As Long, MyLeft As Double, MyTop As Double, _
    MyHeight As Double, MyWidth As Double

With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    
        Set wks = Sheets("Prof Pro") 'adjust sheet to your needs
        wks.Activate

        LastRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row 'Find the last row

        Set myRange = wks.Range(Cells(2, 19), Cells(LastRow, 19)) ' adjust range to your needs

        For i = 2 To LastRow

          Select Case wks.Cells(i, 3).Value
            
            Case Is = 200001 > 0
                With Cells(i, "S")
                    MyLeft = .Left
                    MyTop = .Top
                    MyHeight = .Height
                    MyWidth = MyHeight '= Cells(i, "S").Width
                End With
    
                With ActiveSheet.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight)
                        .Caption = ""
                        '.Value = xlOff
                        .LinkedCell = "S" & i
                        '.Display3DShading = False
                End With
            Case Is > 200001
                Exit Sub
          End Select
        Next i

        .StatusBar = ""
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

End Sub

Thank you Rhodie for the help!

Still having problems though - I tried running the script, and though it runs in a few seconds, no Check Boxes are showing up