Odtnhj

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