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]

Give this non-looping macro a try...

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

 

[kevin9999]

Slight variation from Rick's method...

Sub Heather515()
    With ActiveSheet
        i = .Cells(.Rows.Count, "A").End(xlUp).Row
        x = "=if(A2:A" & i & "= ""apple"",1,if(A2:A" & i & "="""","""",0))"
        .Range("B2:B" & i).Value = Application.Evaluate(x)
    End With
End Sub

 

[Heather515]

Give this non-looping macro a try...

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

Data.xlsx
	A
23	NotenoteFishNoenote
Sheet1

Thanks. It works on the example data I uploaded. However, I have problems when I run the code in new data that are slightly different from the data I uploaded. I uploaded the second worksheet I'm working. How should I adjust the code? Thanks again!

 

[Heather515]

Slight variation from Rick's method...

Sub Heather515()
    With ActiveSheet
        i = .Cells(.Rows.Count, "A").End(xlUp).Row
        x = "=if(A2:A" & i & "= ""apple"",1,if(A2:A" & i & "="""","""",0))"
        .Range("B2:B" & i).Value = Application.Evaluate(x)
    End With
End Sub

Thanks. As I replied to Rick above, it works in the data I uploaded. But I need some modification in the new data I'm working on. Thanks!

 

[kevin9999]

Thanks. As I replied to Rick above, it works in the data I uploaded. But I need some modification in the new data I'm working on. Thanks!

Unfortunately, I can only see a single cell in what you've provided with your update...

 

[Heather515]

Data.xlsx
	A
23	NotenoteFishNoenote
Sheet1

How about this one? Just in case you can't see it, I also attached the screenshot.

 

[Heather515]

Unfortunately, I can only see a single cell in what you've provided with your update...

Data.xlsx
	A	B
1	Data	Results
2	NoteAppleNoteNoteNote	1
3
4
5	NoteFoodNoteNote	0
6
7	NoteNoteAppleNoteNote	1
8
9	NotenoteNotenotenotenoteBananaNtoenote	0
10
11
12	NtoenoteNotenoteAppleNtoenote	1
13
14
15	NotenoteOrangeNotenote	0
16
17	NOtenoteCoconutNoteno	0
18
19
20	NonotenoteCherriesNotneote	0
21
22
23	NotenoteFishNoenote	0
Sheet1

Here...Thanks.

 

[kevin9999]

Data.xlsx
	A	B
1	Data	Results
2	NoteAppleNoteNoteNote	1
3
4
5	NoteFoodNoteNote	0
6
7	NoteNoteAppleNoteNote	1
8
9	NotenoteNotenotenotenoteBananaNtoenote	0
10
11
12	NtoenoteNotenoteAppleNtoenote	1
13
14
15	NotenoteOrangeNotenote	0
16
17	NOtenoteCoconutNoteno	0
18
19
20	NonotenoteCherriesNotneote	0
21
22
23	NotenoteFishNoenote	0
Sheet1

Here...Thanks.

Thanks Heather. So what are the 'rules' regarding the new data?

 

[kevin9999]

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