VBA Loop объединяет Lastrow и находит пустые значения

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

Ваш вопрос подразумевает, что у вас будет больше критериев для поиска, поэтому я решил продолжить.Вы можете добавить больше критериев здесь, когда вы идете ~

1. Цикл по Column A
2. Если значение пусто, добавьте ячейку в Union (набор ячеек)
3. Как только цикл завершен, скопируйте 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

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

Посмотрите на метод Range.SpecialCells .Вы можете использовать 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