Ndtyjky

I am trying to build a "data check" type file where a series of macros look at a data set and copy/paste incorrect entries into separate sheets based on various criteria. One of these is looking at if the value in Column A is blank.

Below is the code that I currently have. It only takes the first instance of the blank, and I am trying have it loop to find all the blank values in column 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

Have a look at the Range.SpecialCells Method.
You can use SpecialCells(xlCellTypeBlanks) to find all blank cells in a range.

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

I prefer using autofilter for this sort of work since that will capture cells that are blank as the result of formulas (and thus contain "" so they look blank) as blank as well as actually blank cells. Code assumes headers are row 1 and actual data starts in row 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

You question implies you will have more criteria to search for so I decided to keep the loop. You can add more criteria here as you go ~

1. Loop through Column A
   


2. If value is blank add the cell to a Union (collection of cells)


3. Once loop is complete, copy the Union all at once

This can be improved upon by switching from a For i loop to a For Each loop to go through a range. Another way to do this is simply filter Column A by blanks and copy/paste the visible rows that remain.

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