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

我的问题是我希望能够执行此代码块，然后当它完成时，检查下一行......如果B列A和K空白为STOP，否则循环回到顶部并在下一行执行它。如果我有一个漫长的一天，我有时可以拨打20-30个电话，按下20-30次按钮效率不高。

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

这是我的电子表格

Answer 1

这使用AutoFilter

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

初始测试表

Sheet 1中 sheetQ4

<强>结果

Sheet 1中 sheetQ4

无法使用Excel VBA

1 个答案: