Check box problem

[jrussellCW]

Hi there, new to the forum, I have a quick easy question. I am trying to create a macro, using vb, that will add a check box to the cell I have selected, label the check box "Produced" and link the checkbox to the cell 2 cells to the right.
It should also then create a check box in the cell to the right of "produced", and label this new check box "Received" This new check box will be linked to the cell two cells to its right.
The result will be two check-boxes in adjacent cells, returning "true" and "false" to the next two cells over.
Then I will have Two cells that sum up the number of "true's" for each column, So that I can easily see how many commercials each month production has produced, and how many they have received. I thought it would be simple, but it's giving me trouble.
oh, and the check boxes must be limited in size to the size of the cell they are in, there are going to be lots of them down the column.

 

[Warship]

Yes ListBox not TextBox.
Sorry 'bout that.

DL here: http://www.box.net/shared/4vz396qsfrlphgbn83xp

 

[kjacw]

Hey Warship this worked just as I needed it. Wow that fits the bill. Thanks so much. You the man!!!!!!

Only one more thing how would I modify the code to work in column AT of the same worksheet with about 10 different symptoms to fill in the rows next to it just like what happened with the prior code. Can I use the same code in the same worksheet just change the If Target.Column = 10 to the appropriate column and then change the symptoms. Is this possible or do i need to modify the original code to say let's work in two columns with 2 different symptoms?

Thanks again in advance

 

[Warship]

To keep things simple create a seperate Userform for any col you want this solution on.

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  If Target.Column = 10 Then
    If Cells(Target.Row, 1) <> "" Then
      UserForm1.Show
    Else
      MsgBox "No Patient Data", vbCritical, "ERROR"
    End If
    Cancel = True
  End If
  If Target.Column = 46 Then 'Col "AT"
    If Cells(Target.Row, 1) <> "" Then
      UserForm2.Show
    Else
      MsgBox "No Patient Data", vbCritical, "ERROR"
    End If
    Cancel = True
  End If
End Sub

IN THE FORM CODE:
Any "11 To 18" will change to "46 to 55" (for 10 symptoms including "none" as first)
If "none" is not the first item things have to change a whole bunch.
Any "x - 11" will be "x - 46"
Any "1 To 7" will be "1 To 9"
Your Heights should change to avoid scrolling.

That's all I see. (but then I'm also cross-eyed from 12 Hrs of coding today)

So just like last time 'cept UserForm2 this go round
All other variables can stay the same inside the UserForm ie ListBox1 still goes in Userform2

Oh yeah-duh. Change your ProbArr

My pillow is calling.z.z.z.z.z

 

[kjacw]

To keep things simple create a seperate Userform for any col you want this solution on.

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  If Target.Column = 10 Then
    If Cells(Target.Row, 1) <> "" Then
      UserForm1.Show
    Else
      MsgBox "No Patient Data", vbCritical, "ERROR"
    End If
    Cancel = True
  End If
  If Target.Column = 46 Then 'Col "AT"
    If Cells(Target.Row, 1) <> "" Then
      UserForm2.Show
    Else
      MsgBox "No Patient Data", vbCritical, "ERROR"
    End If
    Cancel = True
  End If
End Sub

Sorry for the misunderstanding.
So does this code replaces the existing code that I now have in the data sheet or does it go in the data sheet as well and the codes that are to be put in the ListBox2 needs to modified to indicate this now the new form according to what you have indicated to me before. I think that is the gist of what you are saying. Correct?

And happy coding and yes get some sleep. But thanks this is great vba that you have helped me with. THANKS MUCH!!!

 

[kjacw]

Thanks Warship but I figured it out Thanks man you are the BEST. ray:


It works great on 2 columns but I did just include 10 symptoms on column 46 but I included 15 symptoms and also changed the width of the ListBox to prevent scrolling.

 

[jrussellCW]

Hey there guys, a few more quick questions. On my former check box issue:
one, is there a way to limit the check boxes so that only one can be checked at a time, preferably if you check one, the other automatically un-checks. And two, can I make excel highlight or outline in red (draw a big arrow, really anything that get my attention) check boxes in a row which are both un-checked. I was thinking it would probably be something that watches the hidden "true/false" column and takes action if it sees two falses or two trues. Thanks guys!

 

[Warship]

This is your highlighting.

Sub CreateCheckBoxes()
    Const cHL As Long = 10 'set to # of cols to highlight
    Dim c As Range, r As Long, x As Long
    Application.ScreenUpdating = False
    r = Application.InputBox("How many rows?", "", 1, , , , , 1) - 1
    For x = ActiveCell.Row To ActiveCell.Row + r
      Set c = ActiveCell
      ActiveSheet.CheckBoxes.Add(c.Left, c.Top, c.Width, c.Height).Select
      With Selection
        .Characters.Text = "Produced"
        .LinkedCell = c.Offset(, 2).Address
        .Value = xlOn
        .Value = xlOff
      End With
      c.Resize(1, cHL).Select
      Selection.FormatConditions.Add Type:=xlExpression, _
        Formula1:="=IF(AND(" & ActiveCell.Offset(, 2).Address & "=FALSE," & _
        ActiveCell.Offset(, 3).Address & "=FALSE),1,0)"
      Selection.FormatConditions(1).Interior.Color = 65535
      Set c = ActiveCell.Offset(, 1)
      ActiveSheet.CheckBoxes.Add(c.Left, c.Top, c.Width, c.Height).Select
      With Selection
        .Characters.Text = "Received"
        .LinkedCell = c.Offset(, 2).Address
        .Value = xlOn
        .Value = xlOff
      End With
      ActiveCell.Offset(1).Select
    Next x
End Sub

I'll have to look at:

is there a way to limit the check boxes so that only one can be checked at a time, preferably if you check one, the other automatically un-checks.

 

[Warship]

I think this does it...

Option Explicit

Sub CreateCheckBoxes()
    Const cHL As Long = 10 'set to # of cols to highlight
    Dim c As Range, r As Long, x As Long
    Application.ScreenUpdating = False
    r = Application.InputBox("How many rows?", "", 1, , , , , 1) - 1
    For x = ActiveCell.Row To ActiveCell.Row + r
      Set c = ActiveCell
      ActiveSheet.CheckBoxes.Add(c.Left, c.Top, c.Width, c.Height).Select
      With Selection
        .Characters.Text = "Produced"
        .Name = "chbxPro" & x
        .OnAction = "ControlCheckBoxes"
        .LinkedCell = c.Offset(, 2).Address
        .Value = xlOn
        .Value = xlOff
      End With
      c.Resize(1, cHL).Select
      Selection.FormatConditions.Add Type:=xlExpression, _
        Formula1:="=IF(AND(" & ActiveCell.Offset(, 2).Address & "=FALSE," & _
        ActiveCell.Offset(, 3).Address & "=FALSE),1,0)"
      Selection.FormatConditions(1).Interior.Color = 65535
      Set c = ActiveCell.Offset(, 1)
      ActiveSheet.CheckBoxes.Add(c.Left, c.Top, c.Width, c.Height).Select
      With Selection
        .Characters.Text = "Received"
        .Name = "chbxRec" & x
        .OnAction = "ControlCheckBoxes"
        .LinkedCell = c.Offset(, 2).Address
        .Value = xlOn
        .Value = xlOff
      End With
      ActiveCell.Offset(1).Select
    Next x
End Sub

Sub ControlCheckBoxes()
  Dim chbx As String
  With ActiveSheet
    chbx = .Shapes(Application.Caller).Name
    If Left(chbx, 7) = "chbxPro" Then
      If .Shapes(chbx).ControlFormat.Value = 1 Then
        .Shapes("chbxRec" & Right(chbx, Len(chbx) - 7)).ControlFormat.Value = 0
      End If
    ElseIf Left(chbx, 7) = "chbxRec" Then
      If .Shapes(chbx).ControlFormat.Value = 1 Then
        .Shapes("chbxPro" & Right(chbx, Len(chbx) - 7)).ControlFormat.Value = 0
      End If
    End If
  End With
End Sub

 

[jrussellCW]

Excellent, that did exactly what I need. Thanks!

 

[kjacw]

This is where shg's suggestion would reduce setup time. It only involves inserting new columns and a bit of VBA placed in the Sheet Module to automate:

Option Explicit

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  If Target.Column > 9 And Target.Column < 26 Then
    Select Case Target.Column
      Case 10
        If Target = "" Then
          Target = "a"
          Target.Font.Name = "Marlett"
          Target.Offset(, 2) = ""
          Target.Offset(, 4) = ""
          Target.Offset(, 6) = ""
          Target.Offset(, 8) = ""
          Target.Offset(, 10) = ""
          Target.Offset(, 12) = ""
          Target.Offset(, 14) = ""
        End If
      Case 12, 14, 16, 18, 20, 22, 24
        If Target = "" Then
          Target = "a"
          Target.Font.Name = "Marlett"
          Target.Offset(, -1 * (Target.Column - 10)) = ""
        Else
          Target = ""
          If Cells(Target.Row, 12) = "" And _
            Cells(Target.Row, 14) = "" And _
            Cells(Target.Row, 16) = "" And _
            Cells(Target.Row, 18) = "" And _
            Cells(Target.Row, 20) = "" And _
            Cells(Target.Row, 22) = "" And _
            Cells(Target.Row, 24) = "" Then
            Target.Offset(, -1 * (Target.Column - 10)) = "a"
            Target.Offset(, -1 * (Target.Column - 10)).Font.Name = "Marlett"
          End If
        End If
    End Select
    Cancel = True
  End If
End Sub

I do understand what you'd like to accomplish however, as stated, a dropdown with checkboxes doesn't exist as far as I know.

If you place a listbox (with ckbx's) in the cell and leave the row height equal to one line of the list, you will still have to be clicking scroll controls to find your items to check/uncheck which seems just as laborious as multiple ckbx's across the sheet. And you'll need alot of VBA to control cell updates.

Another option is to increase row height to accommodate the entire list leaving all ckbx's exposed all the time, of course total over-all height of sheet increases significantly. And you'll need alot of VBA to control cell updates.

Another option is to increase listbox height when the listbox gets focus but a lot of VBA would be required to control cell updates and to make it dynamic.

The only other option I see is to go with a UserForm which I’ve done here:

Create UserForm1
Create TextBox1 in Userform1

Place this code in Userform1:

Option Explicit
Dim ProbArr As Variant
Dim x As Integer, r As Long
Dim skipevent As Boolean

Private Sub UserForm_Initialize()
  r = ActiveCell.Row
  ProbArr = Array("none", "arthritis", "asthma", "cardiac", "hypertension", "stomach", "HIV", "kidney")
  Me.Height = 131.25
  Me.Width = 106.5
  Me.Caption = Cells(r, 1)
  ListBox1.Height = 105.05
  ListBox1.Width = 90
  ListBox1.Top = 0
  ListBox1.Left = 6
  ListBox1.MultiSelect = fmMultiSelectMulti
  ListBox1.ListStyle = fmListStyleOption
  ListBox1.Clear
  For x = 0 To UBound(ProbArr)
    ListBox1.AddItem ProbArr(x)
  Next x
  For x = 11 To 18
    skipevent = True
    If Cells(r, x) <> "" Then
      ListBox1.Selected(x - 11) = True
    End If
    skipevent = False
  Next x
  If NoneSelected Then
    skipevent = True
    ListBox1.Selected(0) = True
    skipevent = False
  End If
End Sub

Private Sub UserForm_Terminate()
    For x = 11 To 18
      If ListBox1.Selected(x - 11) Then
        Cells(r, x) = ProbArr(x - 11)
      Else
        Cells(r, x) = ""
      End If
    Next x
End Sub

Private Sub ListBox1_Change()
  If skipevent Then Exit Sub
  Select Case ListBox1.ListIndex
    Case 0
      If ListBox1.Selected(0) Then
        skipevent = True
        For x = 1 To 7
          ListBox1.Selected(x) = False
        Next x
        skipevent = False
      Else
        skipevent = True
        ListBox1.Selected(0) = True
        skipevent = False
      End If
    Case Else
      If ListBox1.Selected(ListBox1.ListIndex) Then
        skipevent = True
        ListBox1.Selected(0) = False
        skipevent = False
      Else
        If NoneSelected Then
          skipevent = True
          ListBox1.Selected(0) = True
          skipevent = False
        End If
      End If
  End Select
End Sub

Private Function NoneSelected()
    NoneSelected = True
    For x = 1 To 7
      If ListBox1.Selected(x) = True Then
        NoneSelected = False
        Exit For
      End If
    Next x
End Function

Place this code in Sheet Module of your Patient Data Sheet:

Option Explicit

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  If Target.Column = 10 Then
    If Cells(Target.Row, 1) <> "" Then
      UserForm1.Show
    Else
      MsgBox "No Patient Data", vbCritical, "ERROR"
    End If
    Cancel = True
  End If
End Sub

Right-clicking in Column J will bring up the form.

Hello after having used this code for some time I would like to modify it to be used in another project but I would like to duplicate the entries if necessary. For example

I have a table with Time Mon Tues Wed...Fri ( The Time portions will not be changed using code )
I have set up the code above to allow a form to pop up to populate Mon - Fri with classes that the teacher needs to fulfill for example

7:30 - 8:20 Mon. French Tue Bible Wed. French Thur. Math Fri. French

8:20 - 9:10 Mon. Math Tue ESL Wed. Math Thur. Math Fri. ESL

How could I modify the above code to allow duplication of choices as the example above gives