Find the next empty cell in a column and insert the next sequential number

Question

I need to find the end of a list and then skip to the next cell and enter "Question " + k . Where k is the number of cells with text so far in the column. The worksheet should look like this:

Question 1
Question 2
-------------> Here insert "Question " + count of non-empty cells (Which should return Question 3)

Here is my code in full:

    Option Explicit


Private Sub cmdbtnAddQuestion_Click()

   Worksheets("QuestionsToAnswerBucket").Activate

   If IsEmpty(Range("A7")) Then
            Range("A7").Activate
            ActiveCell = "Question 1"
        ElseIf IsEmpty(Range("B8")) Then
            Range("A8").Activate
            ActiveCell = "Question 2"
        ElseIf IsEmpty(Range("B9")) Then
            Range("A9").Activate
            ActiveCell = "Question 3"
        ElseIf IsEmpty(Range("B10")) Then
            Range("A10").Activate
            ActiveCell = "Question 4"
        ElseIf IsEmpty(Range("B11")) Then
            Range("A11").Activate
            ActiveCell = "Question 5"
        ElseIf IsEmpty(Range("B12")) Then
            Range("A12").Activate
            ActiveCell = "Question 6"
        Else
            Worksheets("QuestionQueue").Activate
            k = Application.WorksheetFunction.CountIf(Range("A2:A200"), "*")

            If IsEmpty(Range("A7")) Then
                Range("A7").Activate
                ActiveCell = "Question 1"
            Else
                Range("A7").End(xlDown).Offset(1, 0).Select
                ActiveCell.Value = "Question " & (k + 1)
                ActiveCell.Font.Bold = True
            End If
        End If

   If txtAddAQuestion.Value = "" Then
            MsgBox "Please Insert A Question"
        Else:
            ActiveCell.Offset(0, 1).Value = txtAddAQuestion.Value
            ActiveCell.Font.Bold = True
        End If
    Unload Me

End Sub

Answer 1

This is my final answer. It seems to work well (6 full tests) - I will continue to test it.

Option Explicit

Private Sub cmdbtnAddQuestion_Click()

   Worksheets("QuestionsToAnswerBucket").Activate

   If IsEmpty(Range("B7")) Then
            Range("A7").Activate
            ActiveCell = "Question 1"
        ElseIf IsEmpty(Range("B8")) Then
            Range("A8").Activate
            ActiveCell = "Question 2"
        ElseIf IsEmpty(Range("B9")) Then
            Range("A9").Activate
            ActiveCell = "Question 3"
        ElseIf IsEmpty(Range("B10")) Then
            Range("A10").Activate
            ActiveCell = "Question 4"
        ElseIf IsEmpty(Range("B11")) Then
            Range("A11").Activate
            ActiveCell = "Question 5"
        ElseIf IsEmpty(Range("B12")) Then
            Range("A12").Activate
            ActiveCell = "Question 6"
        Else
            Worksheets("QuestionQueue").Activate
            **k = Application.CountIf(Cells, "Question *")

            If IsEmpty(Range("B7")) Then
                Range("A7").Activate
                ActiveCell = "Question 1"
            Else
                Range("A7").Offset(k, 0).Activate
                ActiveCell.Value = Format(k + 1, "\Qu\e\stio\n 0")**
                ActiveCell.Font.Bold = True
            End If
        End If

   If txtAddAQuestion.Value = "" Then
            MsgBox "Please Insert A Question"
        Else:
            ActiveCell.Offset(0, 1).Value = txtAddAQuestion.Value
            ActiveCell.Font.Bold = True
        End If
    Unload Me

End Sub

Answer 2

The problem you are having is that on the second pass you are taking the .End(xlDown) from the occupied A7 cell. However, if there is nothing in A8:A1048576, you are going to A1048576 and then trying to use the Range .Activate method to select the cell below that. There is no cell below that so you receive the

Runtime error: 1004.
Application-defined or object-defined error.

Try something closer to one of these.

Option 1 (very different approach):

Sub AddQuestionQueue()
    Dim k As Long

    With Worksheets("QuestionQueue")
        With Range("A2:A" & Rows.Count)
            k = Application.CountIf(.Cells, "Question *")
        End With
        With .Range("A7").Offset(k, 0)
            .Value = Format(k + 1, "\Qu\e\stio\n 0")
            .Font.Bold = True
        End With
    End With

End Sub

Option 2 (closer to your original):

Sub AddQuestionQueue_orig()
    Dim k As Long, r As Long

    With Worksheets("QuestionQueue")
        r = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        k = Application.CountIf(.Range("A7:A" & Rows.Count), "Question *")

        With .Range("A" & Application.Max(r, 7))
            .Value = "Question " & (k + 1)
            .Font.Bold = True
        End With
    End With

End Sub

Typically, it is better to look for the last occupied cell coming from the bottom up (eg .Cells(Rows.Count, 1)>End(xlUp) ) than from the bottom down. In the first option above, a simple Range.Offset using the number of previous questions allowed one routine for all; not a separate one for a blank A7. The second option is closer to your own code but looks from the bottom up with a minimum row number of 7.

See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.