Vba loop only when cells are not blank

[Heather515]

Data.xlsx
	D
6
Sheet1

I need help with making my code more efficient. As you can see, I want to code "Apple" as "1", and everything else as "0". However, I want to leave other cells blank when the cells in the first column is also blank. My current code first return 1 for Apple and 0 for others (including blank cells), and then I run the loop to remove 0 generated from the first step. It takes too long to remove the unwanted zeros since I have hundreds of thousands rows. I also need to keep the blank rows for merging data later.

Could you please help change my code or write a new code so cells with "Apple" return value of "1" and only other non-blank cells return value of "0" so I don't need to spend extra time to remove the unwanted zeros. Thanks!


Sub Apple()

Dim LRow As Long

LRow = Cells(Rows.Count, 1).End(xlUp).Row

For x = 2 To LRow

If InStr(Cells(x, 1), "Apple") > 0 Then
Cells(x, 2) = "1"
Else
Cells(x, 2) = "0"
End If
Next x

For x = 2 To LRow

If IsEmpty(Cells(x, 1)) Then

Cells(x, 2) = ""

End If

Next x


End Sub

 

[Rick Rothstein]

Does this work with your actual data...

Sub Apples()
  With Range("A2", Cells(Rows.Count, "A").End(xlUp))
    .SpecialCells(xlConstants).Offset(, 1) = 0
    .Offset(, 1) = Evaluate(Replace("IF(@="""","""",0+ISNUMBER(SEARCH(""apple"",@)))", "@", .Address))
  End With
End Sub

 

[Heather515]

Try this...

Sub Heather515B()
    Dim i As Long, j As Long, ws As Worksheet, arrIn, arrOut
    Set ws = ActiveSheet
    i = ws.Cells(Rows.Count, 1).End(xlUp).Row
    arrIn = ws.Range(ws.Cells(2, 1), ws.Cells(i, 2))
    ReDim arrOut(1 To UBound(arrIn), 1 To 1)

    For j = 1 To i - 1
        If arrIn(j, 1) Like "*apple*" Then
            arrOut(j, 1) = 1
            ElseIf arrIn(j, 1) = "" Then
            arrOut(j, 1) = ""
            Else
            arrOut(j, 1) = 0
        End If
    Next j
    ws.Range("B2").Resize(UBound(arrOut)).Value = arrOut
End Sub

Thank you very much. It works perfectly!

 

[Heather515]

Does this work with your actual data...

Sub Apples()
  With Range("A2", Cells(Rows.Count, "A").End(xlUp))
    .SpecialCells(xlConstants).Offset(, 1) = 0
    .Offset(, 1) = Evaluate(Replace("IF(@="""","""",0+ISNUMBER(SEARCH(""apple"",@)))", "@", .Address))
  End With
End Sub

Does this work with your actual data...

Sub Apples()
  With Range("A2", Cells(Rows.Count, "A").End(xlUp))
    .SpecialCells(xlConstants).Offset(, 1) = 0
    .Offset(, 1) = Evaluate(Replace("IF(@="""","""",0+ISNUMBER(SEARCH(""apple"",@)))", "@", .Address))
  End With
End Sub

Thanks. It works!

 

[kevin9999]

Thank you very much. It works perfectly!

I'm glad we could help, and thank you for the feedback