Question

我正在尝试构建“数据检查”类型的文件，其中一系列宏会查看数据集，并根据各种条件将不正确的条目复制/粘贴到单独的工作表中。其中之一是查看列A中的值是否为空白。

下面是我当前拥有的代码。它只使用空白的第一个实例，我正在尝试使其循环以查找列A中的所有空白值。

Sub copy_blanks()  
    Dim sr As Range
    Dim blank As Long
    Dim i As Integer
    Dim s1 As Worksheet
    Dim s2 As Worksheet

    Set s1 = Worksheets("data")
    Set s2 = Worksheets("No LoadID")

    lr2 = s2.Cells(Rows.Count, 2).End(xlUp).Row

    Set sr = Worksheets("data").Range("A:A").Find("")

    If Not sr Is Nothing Then  
        blank = sr.Row
        s1.Rows(blank).Copy
        s2.Cells(lr2 + 1, 1).PasteSpecial xlPasteValues
    End If
End Sub

Answer 1

看看Range.SpecialCells Method。您可以使用SpecialCells(xlCellTypeBlanks)查找范围内的所有空白单元格。

Dim wsData As Worksheet
Set wsData = Worksheets("data")

Dim LastDataRow As Range
Set LastDataRow = wsData.Cells(Rows.Count, "A").End(xlUp) 'last used cell in column A

Dim wsNoID As Worksheet
Set wsNoID = Worksheets("No LoadID")

Dim BlankCells As Range
On Error Resume Next 'next line will throw an error if no blanks are found
Set BlankCells = wsData.Range("A1", LastDataRow).SpecialCells(xlCellTypeBlanks) 'find all blank cells in column A until last data row
On Error Goto 0 're-activate error messages!

If Not BlankCells Is Nothing Then
    BlankCells.EntireRow.Copy

    wsNoID.Cells(Rows.Count, 2).End(xlUp).Offset(1, -1).PasteSpecial xlPasteValues
Else
    MsgBox "No blanks found."
End If

Answer 2

我更喜欢将自动过滤器用于此类工作，因为这将捕获由于公式而为空的单元格（因此包含""，因此它们看起来为空白）以及空白单元格和实际上是空白单元格。代码假定标题是第1行，实际数据从第2行开始。

Sub copy_blanks()

    Dim s1 As Worksheet
    Dim s2 As Worksheet
    Dim lr2 As Long

    Set s1 = ActiveWorkbook.Worksheets("data")
    Set s2 = ActiveWorkbook.Worksheets("No LoadID")

    lr2 = s2.Cells(s2.Rows.Count, 2).End(xlUp).Row

    With s1.Range("A1:A" & s1.Cells(s1.Rows.Count, "B").End(xlUp).Row)
        .AutoFilter 1, "="
        .Offset(1).EntireRow.Copy
        s2.Cells(lr2 + 1, "A").PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        .AutoFilter
    End With

End Sub

Answer 3

您的问题暗示您将有更多搜索条件，因此我决定保留该循环。您可以在此处添加更多条件〜

遍历Column A
如果值为空，则将单元格添加到Union（单元格集合）中
循环完成后，一次复制Union

这可以通过从For i循环切换到For Each循环以遍历某个范围来改善。执行此操作的另一种方法是简单地用空格过滤Column A并复制/粘贴剩余的可见行。

Option Explicit

Sub Blanks()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("data")
Dim db As Worksheet: Set db = ThisWorkbook.Sheets("No LoadID")

Dim LROw As Long, i As Long, Blanks As Range

For i = 2 To ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    If ws.Range("A" & i) = "" Then
        If Not Blanks Is Nothing Then
            Set Blanks = Union(Blanks, ws.Range("A" & i))
        Else
            Set Blanks = ws.Range("A" & i)
        End If
    End If
Next i

If Not Blanks Is Nothing Then
    Blanks.EntireRow.Copy db.Range("B" & db.Rows.Count).End(xlUp).Offset(1, -1).Row
End If

End Sub

结合Lastrow和查找空白值的VBA循环

3 个答案: