vba - 使用 Excel VBA 创建有效的退出条件时遇到问题

Question

首先发表所有内容，因此请原谅任何语法错误:我已经在工作中处理电子表格很长时间了。它的目的是记录我的调用，因为我在一个大容量的入站客户服务调用中心工作。有时我需要跟进我的客人。

工作表为 A:K 列，从第 5 行开始

最终，我正在编写一个程序来检查我的记录，忽略 K 列中包含数据的任何行，然后当它找到有效数据时，将记录复制到另一张表，然后返回主表。该部分工作正常，下面是代码:

Sub Button2_Click()

Dim sourceEmptyRow As Long
Dim targetEmptyRow As Long
Dim sourceRange As Range
Dim targetRange As Range


'Make Today active
 Sheet1.Activate

'Set Variables
 sourceEmptyRow = FindNextEmpty(Range("K5")).Row
 Set sourceRange = Rows(sourceEmptyRow)
 sourceRange.Copy

'Activate Next Sheet
 sheetQ4.Activate

'Set Variables
 targetEmptyRow = FindNextEmpty(Range("A1")).Row
 Set targetRange = Rows(targetEmptyRow)

 targetRange.PasteSpecial
 Sheet1.Activate
 sourceRange.Delete Shift:=xlUp

End Sub

这是 FindNextEmpty() 函数(我很确定我在这里找到了它)

Public Function FindNextEmpty(ByVal rCell As Range) As Range
'Finds the first empty cell downwards in a column.

On Error GoTo ErrorHandle

With rCell
   'If the start cell is empty it is the first empty cell.
   If Len(.Formula) = 0 Then
      Set FindNextEmpty = rCell
      'If the cell just below is empty
   ElseIf Len(.Offset(1, 0).Formula) = 0 Then
      Set FindNextEmpty = .Offset(1, 0)
   Else
      'Finds the last cell with content.
      '.End(xlDown) is like pressing CTRL + arrow down.
      Set FindNextEmpty = .End(xlDown).Offset(1, 0)
   End If
End With

Exit Function
ErrorHandle:
MsgBox Err.Description & ", Function FindNextEmpty."
End Function

我的问题是我希望能够执行此代码块，然后在完成后检查下一行...如果 A 列和 K 列均为空白则停止，否则循环回到顶部并在下一行执行它。如果我一天的时间很长，有时我会接到 20-30 个电话，按 20-30 次按钮效率很低。

自 2003 年左右以来，我就没有认真编码过，所以我是一个极端的新手。 感谢您提供的任何帮助、想法和见解。

这是我的电子表格

Answer 1

这使用了自动过滤器

<小时/>

Option Explicit

Public Sub MoveCompleted()
    Const COL_K = 11
    Const TOP_ROW = 5
    Dim ws1 As Worksheet:   Set ws1 = sheetToday    '<--- Source sheet
    Dim ws2 As Worksheet:   Set ws2 = sheetQ118     '<--- Destination sheet
    Dim maxRows As Long, ws1ur As Range

    optimizeXL True
    With ws1.UsedRange
        If ws1.AutoFilterMode Then .AutoFilter
        maxRows = .Rows.Count

        .Offset(TOP_ROW - 2).Resize(maxRows - (TOP_ROW - 2)).AutoFilter 'ur + header row

        .AutoFilter Field:=COL_K, Criteria1:="="    'show only blanks in K
        Set ws1ur = .Offset(TOP_ROW - 1).Resize(maxRows - TOP_ROW + 1, .Columns.Count)

        On Error Resume Next
        Set ws1ur = ws1ur.SpecialCells(xlCellTypeVisible)
        If Err.Number <> 0 Then
            Err.Clear
        Else
            ws1ur.Copy ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
            ws1ur.EntireRow.Delete
        End If
        On Error GoTo 0
        .AutoFilter Field:=COL_K
    End With
    optimizeXL False
End Sub

<小时/>

Public Sub optimizeXL(Optional ByVal settingsOff As Boolean = True)
    With Application
        .ScreenUpdating = Not settingsOff
        .Calculation = IIf(settingsOff, xlCalculationManual, xlCalculationAutomatic)
        .EnableEvents = Not settingsOff
    End With
End Sub

<小时/>

初始测试表

表1 片材Q4

<小时/>

结果

表1 片材Q4