Pre-Fill User Form Based on Cell Content

jimmydrsv

New Member
Joined
Feb 12, 2015
Messages
11
I have a user form that activates when a cell in a specific range is selected. The userform specifies an insurer with 3 optionbuttons and therapy services rendered with 3 checkboxes. When I run the form, it will save into the selected cell a string value such as Medicare A: Physical Therapy Occupational Therapy Speech therapy.

The code works as intended, but what I am now running into trouble doing is the reverse. I want to be able to click on the cell and have it show the user form with the buttons and checkboxes selected based on the string value in the cell.

Here is my userform:
Code:
Private Sub CommandButton1_Click()ActiveSheet.Unprotect
Dim Insurer As String
Dim PT As String
Dim OT As String
Dim ST As String
If OptionButton1.Value = True Then Insurer = "A: "
If OptionButton2.Value = True Then Insurer = "HMO: "
If OptionButton3.Value = True Then Insurer = "B: "
If CheckBox1.Value = True Then PT = "PT "
If CheckBox2.Value = True Then OT = "OT "
If CheckBox3.Value = True Then ST = "ST "
If Not Me.OptionButton1 And Not Me.OptionButton2 And Not Me.OptionButton3 Then
 Me.Hide
 MsgBox "You must select an insurer.", vbOKOnly, "Selection Required"
 Me.Show
 Else
ActiveCell = Insurer & PT & OT & ST
Unload Me
    With Worksheets("Sheet1")
        .Activate
        .Range("A1").Select
    End With
ActiveSheet.Protect
End If
End Sub


Private Sub CommandButton2_Click()
ActiveSheet.Unprotect
CheckBox1 = False
CheckBox2 = False
CheckBox3 = False
OptionButton1 = False
OptionButton2 = False
OptionButton3 = False
Selection.ClearContents
Unload Me
ActiveSheet.Protect
End Sub


Private Sub CommandButton3_Click()
Unload Me
End Sub

Here is my efforts trying to show the userform with the PT value triggering optionbutton1 to change to true.
Code:
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim CellText As String
 On Error Resume Next


 If Target.Column = 5 And Target.Row < 64 And Target.Row > 1 Then
 UserForm1.Show
CellText = ActiveCell.Text
If InStr(1, CellText, "PT", vbTextCompare) > 0 Then CheckBox1.Value = True
 End If




 End Sub
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Try this:
Code:
If InStr(1, CellText, "PT", vbTextCompare) > 0 Then OptionButton1.Value = True
 
Upvote 0
Hi,
To do what you want you would use your Forms UserForm_Intialize event.
Place following code in your forms code page:

Code:
 Option Base 1

Private Sub UserForm_Initialize()
        Dim CellText As String
        Dim i As Integer
        Dim arr1 As Variant, arr2 As Variant
    
        arr1 = Array("A", "HMO:", "B:")
        arr2 = Array("PT", "OT", "ST")
        CellText = ActiveCell
        
        For i = 1 To 3
            Me.Controls("OptionButton" & i).Value = InStr(1, CellText, arr1(i), vbTextCompare) > 0
            Me.Controls("CheckBox" & i).Value = InStr(1, CellText, arr2(i), vbTextCompare) > 0
        Next i
End Sub

Note Option Base 1 – It MUST sit at very TOP of your forms code page outside of any procedure.

Your worksheet selection change event needs to be updated as follows:

Code:
 Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Not Intersect(Target, Me.Range("E2:E63")) Is Nothing Then UserForm1.Show


 
 End Sub

Hope Helpful

Dave
 
Upvote 0
That worked perfectly, thank you Dave.

Most welcome

You can use the same array to manage action in your commanbutton which reduces most of those IF's statements.

Code:
Option Base 1
Dim arr1 As Variant, arr2 As Variant
Private Sub UserForm_Initialize()
        Dim CellText As String
        Dim i As Integer
        
        arr1 = Array("A: ", "HMO: ", "B: ")
        arr2 = Array("PT ", "OT ", "ST ")
        
        CellText = ActiveCell
        
        For i = 1 To 3
            Me.Controls("OptionButton" & i).Value = InStr(1, CellText, arr1(i), vbTextCompare) > 0
            Me.Controls("CheckBox" & i).Value = InStr(1, CellText, arr2(i), vbTextCompare) > 0
        Next i
End Sub


Private Sub CommandButton1_Click()


    Dim Insurer As Variant
    Dim PTOTST As String
       
    ActiveSheet.Unprotect
    
    For i = 1 To 3
        If Me.Controls("OptionButton" & i) Then Insurer = arr1(i)
        If Me.Controls("CheckBox" & i) Then PTOTST = PTOTST & arr2(i)
    Next i


    If IsEmpty(Insurer) Then
        MsgBox "You must select an insurer.", 48, "Selection Required"


    Else
        ActiveCell = Insurer & PTOTST


        With Worksheets("Sheet1")
            .Activate
            .Range("A1").Select
        End With
    End If
    'ActiveSheet.Protect
End Sub

Dave
 
Upvote 0
I have one more issue I am trying to work out. I want the userform to load only if a cell 3 to the left is not blank, otherwise I want it to prompt the user to place an entry into that cell first. With only the first condition, the code works, but it errors with the elseif statement included

Code:
 Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Not Intersect(Target, Me.Range("E2:E63")) Is Nothing And Selection.Cells.Count = 1 And Not IsEmpty(ActiveCell.Offset(columnoffset:=-3).Value) Then UserForm1.Show
ElseIf Not Intersect(Target, Me.Range("E2:E63")) Is Nothing And Selection.Cells.Count = 1 And IsEmpty(ActiveCell.Offset(columnoffset:=-3).Value) Then MsgBox "Place a resident/Patient into the room first."
 End Sub
 
Upvote 0
see if this does what you want:

Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)


    If Not Intersect(Target, Me.Range("E2:E63")) Is Nothing Then
        If Len(Target.Offset(0, -3).Value) > 0 Then
            UserForm1.Show
        Else
            MsgBox "Place a Resident/Patient into the room first.", 48, "Entry Required"
            Target.Offset(0, -3).Select
            
        End If
    End If
End Sub

Adjust code as required.

Dave
 
Upvote 0

Forum statistics

Threads
1,213,557
Messages
6,114,293
Members
448,564
Latest member
ED38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top