Fibonacci Sequence that deletes even numbers VBA - vba

Question

Over the school holidays I was tasked with creating code that would output the Fibonacci sequence up to a certain number (in this case, the number I was given was 100000). Then, from that, I was ordered with deleting the cells that had even numbers, showing only cells that were odd. I have tried and tried many different method of doing both, but nothing seems to be working for me. Here is the code I was using:
Sub fib()
Dim x As Long
x = 100000
Range("A1") = 0
Range("A2") = 1
Do
If Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Value + _
Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Offset(-1, 0).Value >= x _
Then Exit Sub
Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Offset(1, 0).FormulaR1C1 = _
"=R[-1]C+R[-2]C"
Loop
For Each Cell In Range("A1:A30")
If Cell.Row Mod 2 = 0 Then
Rows(Cell.Row).ClearContents
End If
Next
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
End Sub
Now, I understand there may be a few problems with my code. The main one I see is in the first block, where instead of just inputting the numbers in to the cell, it instead inputs the way it would be calculated (for example, cell A10's value is just given as =A9+A8). I am not sure if this would cause an error in the second part of the code, where it looks for cell values so it can delete whether it is even. Could I please have some assistance on this matter? It would be much appreciated, as I've been struggling with it for the past few days now. Any help is appreciated! :)

Answer 1

Try the code below.
Sub fib()
Dim x As Long
Dim lRow As Long
x = 100000
Range("A1") = 0
Range("A2") = 1
Do
If Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Value + _
Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Offset(-1, 0).Value >= x _
Then Exit Sub
Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Offset(1, 0).FormulaR1C1 = _
"=R[-1]C+R[-2]C"
Columns("A:A").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Loop
With ActiveSheet
lRow = WorksheetFunction.Max(Range("A65536").End(xlUp).Row)
For i = lRow To 2 Step -1
If .Cells(i, "A") Mod 2 = 0 Then
Rows(i).Delete
End If
Next i
End With
End Sub

Answer 2

Generate 30 values using formulas, then freeze those values (remove formulas), then remove any even values or values that exceed the max:
Sub fib()
Dim xMax As Long: xMax = 100000
Range("A1").Value = 0: Range("A2").Value = 1
With Range("A3:A30")
.Formula = "=A1+A2" ' generate using formula
.Value = .Value ' remove formulas and freeze values
End With
' now remove even values and values that exceed the xMax
' Remember to iterate backward when the loop involves deleting
Dim i As Long
For i = Cells(Rows.count, "A").End(xlUp).Row To 3 Step -1
If Cells(i, "A").Value Mod 2 = 0 Or _
Cells(i, "A").Value > xMax Then Rows(i).Delete
Next
End Sub

Answer 3

All this code seems fancier than it needs to be. Does this work?
The Do While..Loop builds your sequence cell by cell in column A up to 100,000.
The For Loop then runs through the list cell by cell and deletes even numbers.
Sub Fib()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim r As Long, x As Long, y As Long, z As Long, i As Long
Dim cell As Range
r = 1
x = 1
y = 0
z = 1
Do While z <= 100000
ws.Range("A" & r).Value = z
r = r + 1
z = x + y
y = x
x = z
Loop
For Each cell In ws.Range("A1", ws.Range("A1").End(xlDown))
If cell.Value Mod 2 = 0 Then cell.EntireRow.Delete
Next cell
End Sub