Need to add items to a named range for a combobox

**rbpd5015** · 05-14-2014, 02:20 PM

So as it stands now I have a named range called "Catagories", which is stored on sheeet "Settings"

it currently has 3 categories, the question is how can I get a user to add an additional category to the named range.

The idea was to have a plus button next to the combobox for Categories on my userform and then the user would enter a new category.

This in turn would update the named range called categories.

below is my code.

Private Sub CBTrvAns1_Click()

If CBTrvAns1.Value = True Then
    CBTrvAns2.Value = False
    CBTrvAns3.Value = False
    CBTrvAns4.Value = False
End If

End Sub

Private Sub CBTrvAns2_Click()

If CBTrvAns2.Value = True Then
    CBTrvAns1.Value = False
    CBTrvAns3.Value = False
    CBTrvAns4.Value = False
End If

End Sub

Private Sub CBTrvAns3_Click()

If CBTrvAns3.Value = True Then
    CBTrvAns2.Value = False
    CBTrvAns1.Value = False
    CBTrvAns4.Value = False
End If

End Sub

Private Sub CBTrvAns4_Click()

If CBTrvAns4.Value = True Then
    CBTrvAns2.Value = False
    CBTrvAns3.Value = False
    CBTrvAns1.Value = False
End If

End Sub

Private Sub CloseBtn_Click()

Dim YesOrNoAnswerToMessageBox As String
Dim QuestionToMessageBox As String

    QuestionToMessageBox = "Are you sure you want to exit the Trivia Question Data Entry Form?"

    YesOrNoAnswerToMessageBox = MsgBox(QuestionToMessageBox, vbYesNo, "Trivia Question Data Entry Form")

    If YesOrNoAnswerToMessageBox = vbNo Then
         MsgBox "Ok", , "Trivia Question Data Entry Form"
    Else
        MsgBox "Goodbye", , "Trivia Question Data Entry Form"
        Unload TriviaQuestions
    End If

End Sub

Private Sub NewQues_Click()
Dim iRow As Long
Dim iaRow As Long
Dim ws As Worksheet
Dim ans As Worksheet
Set ws = Worksheets("Questions")
Set ans = Worksheets("Answers")


'find first empty row in database
  iRow = ws.Cells.Find(What:="*", _
                         SearchOrder:=xlRows, _
                         SearchDirection:=xlPrevious, _
                         LookIn:=xlValues).Row + 1
                         
'find first empty row in database
  iaRow = ans.Cells.Find(What:="*", _
                         SearchOrder:=xlRows, _
                         SearchDirection:=xlPrevious, _
                         LookIn:=xlValues).Row + 1
'check for a Trivia Question
If Trim(Me.TxtQNum.Value) = "" Then
  Me.TxtQNum.SetFocus
  MsgBox "Please enter a Trivia Question"
  Exit Sub
End If

'clear the data
Me.TxtQNum.Value = iRow - 1
Me.TxtTrvQues.Value = ""
Me.CBCat.Value = ""
Me.CBDif.Value = ""
Me.TxtTrvAns1 = ""
Me.TxtTrvAns2 = ""
Me.TxtTrvAns3 = ""
Me.TxtTrvAns4 = ""
Me.CBTrvAns1 = ""
Me.CBTrvAns2 = ""
Me.CBTrvAns3 = ""
Me.CBTrvAns4 = ""
Me.TxtTrvQues.SetFocus

SaveQuestion.Visible = False
SubQues.Visible = True

End Sub
Private Sub SaveQuestion_Click()
Dim ws1 As Worksheet:   Set ws1 = Sheets("Questions")
Dim ws2 As Worksheet:   Set ws2 = Sheets("Answers")
Dim rFind As Range
Dim r2Find As Range

StrQ = TxtQNum.Text
strQu = TxtTrvAns1.Text

Set rFind = ws1.Range("A1:A" & ws1.Range("A" & Rows.Count).End(xlUp).Row).Find(What:=StrQ, LookIn:=xlValues, Lookat:=xlWhole)

If Not rFind Is Nothing Then
    rFind.Offset(0, 0).Value = TxtQNum.Text
    rFind.Offset(0, 1).Value = TxtTrvQues.Text
    rFind.Offset(0, 2).Value = CBCat.Text
    rFind.Offset(0, 3).Value = CBDif.Text
End If

Set r2Find = ws2.Range("A1:A" & ws2.Range("A" & Rows.Count).End(xlUp).Row).Find(What:=StrQ, LookIn:=xlValues, Lookat:=xlWhole)

If Not r2Find Is Nothing Then
    r2Find.Offset(0, 1).Value = TxtTrvAns1.Text
    r2Find.Offset(1, 1).Value = TxtTrvAns2.Text
    r2Find.Offset(2, 1).Value = TxtTrvAns3.Text
    r2Find.Offset(3, 1).Value = TxtTrvAns4.Text
    r2Find.Offset(0, 2).Value = IIf(CBTrvAns1.Value, 1, 0)
    r2Find.Offset(1, 2).Value = IIf(CBTrvAns2.Value, 1, 0)
    r2Find.Offset(2, 2).Value = IIf(CBTrvAns3.Value, 1, 0)
    r2Find.Offset(3, 2).Value = IIf(CBTrvAns4.Value, 1, 0)
End If

SaveQuestion.Visible = True
SubQues.Visible = False
'Show that question was submitted
MsgBox "You question has been saved!", , "Trivia Question Data Entry Form"
  
End Sub

Private Sub SpinButton1_SpinUp()
Dim ws1 As Worksheet:   Set ws1 = Sheets("Questions")
Dim ws2 As Worksheet:   Set ws2 = Sheets("Answers")
Dim rFind As Range
Dim r2Find As Range

StrQ = TxtQNum.Text
strQu = TxtTrvAns1.Text
Set rFind = ws1.Range("A1:A" & ws1.Range("A" & Rows.Count).End(xlUp).Row).Find(What:=StrQ, LookIn:=xlValues, Lookat:=xlWhole)
If rFind.Value = "1" Then Set rFind = ws1.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)

If Not rFind Is Nothing Then
    TxtQNum.Text = rFind.Offset(-1, 0).Value
    TxtTrvQues.Text = rFind.Offset(-1, 1).Value
    CBCat.Text = rFind.Offset(-1, 2).Value
    CBDif.Text = rFind.Offset(-1, 3).Value
End If

Set r2Find = ws2.Range("A1:A" & ws2.Range("A" & Rows.Count).End(xlUp).Row).Find(What:=StrQ, LookIn:=xlValues, Lookat:=xlWhole)
If r2Find.Value = "1" Then Set r2Find = ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)

If Not r2Find Is Nothing Then
    TxtTrvAns1.Text = r2Find.Offset(-4, 1).Value
    TxtTrvAns2.Text = r2Find.Offset(-3, 1).Value
    TxtTrvAns3.Text = r2Find.Offset(-2, 1).Value
    TxtTrvAns4.Text = r2Find.Offset(-1, 1).Value
    CBTrvAns1.Value = r2Find.Offset(-4, 2).Value
    CBTrvAns2.Value = r2Find.Offset(-3, 2).Value
    CBTrvAns3.Value = r2Find.Offset(-2, 2).Value
    CBTrvAns4.Value = r2Find.Offset(-1, 2).Value
      
    
End If
End Sub

Private Sub SpinButton1_SpinDown()
Dim ws1 As Worksheet:   Set ws1 = Sheets("Questions")
Dim ws2 As Worksheet:   Set ws2 = Sheets("Answers")
Dim rFind As Range
Dim r2Find As Range

StrQ = TxtQNum.Text
strQu = TxtTrvAns1.Text

Set rFind = ws1.Range("A1:A" & ws1.Range("A" & Rows.Count).End(xlUp).Row).Find(What:=StrQ, LookIn:=xlValues, Lookat:=xlWhole)
If rFind.Value = ws1.Range("A" & Rows.Count).End(xlUp).Value Then Set rFind = ws1.Range("A1")

If Not rFind Is Nothing Then
    TxtQNum.Text = rFind.Offset(1, 0).Value
    TxtTrvQues.Text = rFind.Offset(1, 1).Value
    CBCat.Text = rFind.Offset(1, 2).Value
    CBDif.Text = rFind.Offset(1, 3).Value
End If

Set r2Find = ws2.Range("A1:A" & ws2.Range("A" & Rows.Count).End(xlUp).Row).Find(What:=StrQ, LookIn:=xlValues, Lookat:=xlWhole)
If r2Find.Value = ws2.Range("A" & Rows.Count).End(xlUp).Value Then Set r2Find = ws2.Range("A1")

If Not r2Find Is Nothing Then
    TxtTrvAns1.Text = r2Find.Offset(4, 1).Value
    TxtTrvAns2.Text = r2Find.Offset(5, 1).Value
    TxtTrvAns3.Text = r2Find.Offset(6, 1).Value
    TxtTrvAns4.Text = r2Find.Offset(7, 1).Value
    CBTrvAns1.Value = r2Find.Offset(4, 2).Value
    CBTrvAns2.Value = r2Find.Offset(5, 2).Value
    CBTrvAns3.Value = r2Find.Offset(6, 2).Value
    CBTrvAns4.Value = r2Find.Offset(7, 2).Value
      
End If
End Sub
Private Sub SubQues_Click()
Dim iRow As Long
Dim iaRow As Long
Dim ws As Worksheet
Dim ans As Worksheet


Me.TxtQNum = TrvQues.Range("A2").Value
Me.TxtTrvQues = TrvQues.Range("B2").Value
Me.CBCat = TrvQues.Range("C2").Value
Me.CBDif = TrvQues.Range("D2").Value
'Check if all questions answered before completing
If Me.TxtWNum.Value = "" Then
   MsgBox "Please answer all Questions!", vbExclamation, "Not Complete!"
   Exit Sub
If Me.TxtTrvQues.Value = "" Then
   MsgBox "Please answer all Questions!", vbExclamation, "Not Complete!"
   Exit Sub
If Me.CBCat.Value = "" Then
   MsgBox "Please answer all Questions!", vbExclamation, "Not Complete!"
   Exit Sub
If Me.CBDif.Value = "" Then
   MsgBox "Please answer all Questions!", vbExclamation, "Not Complete!"
   Exit Sub
If Me.TxtTrvAns1.Value = "" Then
   MsgBox "Please answer all Questions!", vbExclamation, "Not Complete!"
   Exit Sub
If Me.TxtTrvAns2.Value = "" Then
   MsgBox "Please answer all Questions!", vbExclamation, "Not Complete!"
   Exit Sub
If Me.TxtTrvAns3.Value = "" Then
   MsgBox "Please answer all Questions!", vbExclamation, "Not Complete!"
   Exit Sub
If Me.TxtTrvAns4.Value = "" Then
   MsgBox "Please answer all Questions!", vbExclamation, "Not Complete!"
   Exit Sub
If Me.CBTrvAns1.Value = "" Then
   MsgBox "Please answer all Questions!", vbExclamation, "Not Complete!"
   Exit Sub
If Me.CBTrvAns2.Value = "" Then
   MsgBox "Please answer all Questions!", vbExclamation, "Not Complete!"
   Exit Sub
If Me.CBTrvAns3.Value = "" Then
   MsgBox "Please answer all Questions!", vbExclamation, "Not Complete!"
   Exit Sub
If Me.CBTrvAns4.Value = "" Then
   MsgBox "Please answer all Questions!", vbExclamation, "Not Complete!"
   Exit Sub
Set ws = Worksheets("Questions")
Set ans = Worksheets("Answers")

'find first empty row in database
  iRow = ws.Cells.Find(What:="*", _
                         SearchOrder:=xlRows, _
                         SearchDirection:=xlPrevious, _
                         LookIn:=xlValues).Row + 1
                         
'find first empty row in database
  iaRow = ans.Cells.Find(What:="*", _
                         SearchOrder:=xlRows, _
                         SearchDirection:=xlPrevious, _
                         LookIn:=xlValues).Row + 1
                         
'check for a Trivia Question
If Trim(Me.TxtQNum.Value) = "" Then
  Me.TxtQNum.SetFocus
  MsgBox "Please enter a Trivia Question"
  Exit Sub
End If

'copy the data to the database

With ws

  .Cells(iRow, 1).Value = Me.TxtQNum.Value
  .Cells(iRow, 2).Value = Me.TxtTrvQues.Value
  .Cells(iRow, 3).Value = Me.CBCat.Value
  .Cells(iRow, 4).Value = Me.CBDif.Value
  

End With

With ans
  .Cells(iaRow, 1).Value = Me.TxtQNum.Value
  .Cells(iaRow + 1, 1).Value = Me.TxtQNum.Value
  .Cells(iaRow + 2, 1).Value = Me.TxtQNum.Value
  .Cells(iaRow + 3, 1).Value = Me.TxtQNum.Value
  .Cells(iaRow, 2).Value = Me.TxtTrvAns1.Value
  .Cells(iaRow + 1, 2).Value = Me.TxtTrvAns2.Value
  .Cells(iaRow + 2, 2).Value = Me.TxtTrvAns3.Value
  .Cells(iaRow + 3, 2).Value = Me.TxtTrvAns4.Value
  .Cells(iaRow, 3).Value = IIf(Me.CBTrvAns1.Value, 1, 0)
  .Cells(iaRow + 1, 3).Value = IIf(Me.CBTrvAns2.Value, 1, 0)
  .Cells(iaRow + 2, 3).Value = IIf(Me.CBTrvAns3.Value, 1, 0)
  .Cells(iaRow + 3, 3).Value = IIf(Me.CBTrvAns4.Value, 1, 0)


End With

SaveQuestion.Visible = True
SubQues.Visible = False
'Show that question was submitted
  MsgBox "You question has been added!", , "Trivia Question Data Entry Form"
End Sub


Private Sub UserForm_Initialize()
    Dim TrvQues As Worksheet
    Dim TrvAns As Worksheet
    Dim TrvSet As Range
    Dim TrvDif As Range
    Dim ts As Worksheet
    
  Set TrvQues = Worksheets("Questions")
  Set TrvAns = Worksheets("Answers")
  Set ts = Worksheets("Settings")
  
For Each TrvSet In ts.Range("Catagories")
    With Me.CBCat
        .AddItem TrvSet.Value
    End With
Next TrvSet

For Each TrvDif In ts.Range("Difficulty")
    With Me.CBDif
        .AddItem TrvDif.Value
    End With
Next TrvDif



Me.TxtQNum = TrvQues.Range("A2").Value
Me.TxtTrvQues = TrvQues.Range("B2").Value
Me.CBCat = TrvQues.Range("C2").Value
Me.CBDif = TrvQues.Range("D2").Value
Me.TxtTrvAns1 = TrvAns.Range("B2").Value
Me.TxtTrvAns2 = TrvAns.Range("B3").Value
Me.TxtTrvAns3 = TrvAns.Range("B4").Value
Me.TxtTrvAns4 = TrvAns.Range("B5").Value
Me.CBTrvAns1 = TrvAns.Range("C2").Value
Me.CBTrvAns2 = TrvAns.Range("C3").Value
Me.CBTrvAns3 = TrvAns.Range("C4").Value
Me.CBTrvAns4 = TrvAns.Range("C5").Value

SubQues.Visible = False



End Sub