Question

我需要找到列表的结尾，然后跳到下一个单元格并输入"Question " + k。其中k是列中到目前为止具有文本的单元格数。工作表应如下所示：

问题1 问题2
-------------＆GT;这里插入“问题”+非空单元格数（应该返回问题3）

以下是我的完整代码：

    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

这是我的最终答案。它似乎运作良好（6个完整测试） - 我将继续测试它。

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

您遇到的问题是，在第二次通过时，您从占用的A7单元格中取出.End(xlDown)。但是，如果A8中没有任何内容：A1048576，您将转到A1048576，然后尝试使用Range .Activate method选择下面的单元格。下面没有单元格，所以你收到了

运行时错误：1004。应用程序定义或对象定义错误。

尝试更贴近其中一项。

选项1（非常不同的方法）：

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

选项2（更接近原文）：

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

通常情况下，最好从下往上查找最后一个被占用的单元格（例如.Cells(Rows.Count, 1)>End(xlUp)），而不是从下往下查找。在上面的第一个选项中，使用先前问题的数量的简单Range.Offset允许一个例程;空白A7不是单独的一个。第二个选项更接近您自己的代码，但从下往上看，最小行数为7。

有关远离依赖选择和激活以实现目标的更多方法，请参阅How to avoid using Select in Excel VBA macros。

找到列中的下一个空单元格并插入下一个序列号

2 个答案: