find列中的下一个空单元格并插入下一个连续的数字

我需要find列表的末尾，然后跳到下一个单元格，然后input"Question " + k 。 其中k是列中至今为止具有文本的单元格的数量。 工作表应该如下所示：

问题1
问题2
————->这里插入“问题”+非空单元格数（应该返回问题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

你遇到的问题是，你正在从占用的A7单元获取.End(xlDown) 。 但是，如果A8中没有任何内容：A1048576，那么您将转到A1048576，然后尝试使用Range。激活方法来select下面的单元格。 下面没有细胞，所以你收到

运行时错误：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。

请参阅如何避免使用Excel中的selectVBAmacros来获取更多的方法来摆脱依靠select和activate来实现您的目标。

Answer 2

这是我的最终答案。 它似乎运作良好（6全面testing） – 我会继续testing它。

 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