if condition only few steps true VBA/Excel - excel

Question

enter image description hereFor a larger project I need to change the source of values for a column all n*k steps, with n being a rational and k a natural number.
Edit for better understanding:
I have a column with multiple entries (filled by a loop in a makro) and need to find all entries with a common divisor called "testwer" in my makro. This "testwer" should later be editable in an excel sheet via a cellinput (in this case G2)
I've tried by writing a macro , a simplified example looks like the following:
Sub testmam()
Dim testwer, i, j
i = 1
j = 1
testwer = Range("g2").Value 'gets the rational number n
Do Until i = 18 'until end of entries in column is reached
If Cells(i, 1).Value = testwer * j Then 'if cellvalue = n*1,2,...,infty
Cells(i, 2).Value = j 'some output in another cell to check wether the detection was sucessfull
j = j + 1 'check coming cells for next value of n*k
End If
i = i + 1
Loop
End Sub
However, when I run this, it only detects the first few (3-5) solutions. For example for n being 1.5 it found only 1.5, 3 and 4.5 to be true. Starting from values 6 to all following multipliers of 1.5 the if condition seems to turn out false.
Does someone know how this could happen? As the if condition is true for multiple steps, I assume the syntax isn't completely wrong.
Greets

Answer 1

Detect Multipliers
Compact
Sub TestMamCompact()
Const wsName As String = "Sheet1"
Const SourceFirstCellAddress As String = "A1"
Const TestCellAddress As String = "G2"
Const DestinationColumn As String = "B"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim sfCell As Range: Set sfCell = ws.Range(SourceFirstCellAddress)
Dim slCell As Range
Set slCell = ws.Cells(ws.Rows.Count, sfCell.Column).End(xlUp)
If slCell.Row < sfCell.Row Then Exit Sub ' no data
Dim srg As Range: Set srg = ws.Range(sfCell, slCell)
Dim TestWert As Double: TestWert = ws.Range(TestCellAddress).Value
Dim k As Long: k = 1
Dim sCell As Range
For Each sCell In srg.Cells
If IsNumeric(sCell) Then
If sCell.Value = TestWert * k Then
ws.Cells(sCell.Row, DestinationColumn).Value = k
k = k + 1
End If
End If
Next sCell
MsgBox "Results written.", vbInformation
End Sub
Argumented
Sub TestMamTEST()
Const wsName As String = "Sheet1"
Const SourceFirstCellAddress As String = "A1"
Const TestCellAddress As String = "G2"
Const DestinationColumn As String = "B"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim sfCell As Range: Set sfCell = ws.Range(SourceFirstCellAddress)
TestMam sfCell, TestCellAddress, DestinationColumn
' or just:
'TestMam sfCell, "G2", "B"
End Sub
Sub TestMamOneLinerTEST()
TestMam ThisWorkbook.Worksheets("Sheet1").Range("A1"), "G2", "B"
End Sub
Sub TestMam( _
ByVal SourceFirstCell As Range, _
ByVal TestCellAddress As String, _
ByVal DestinationColumn As String)
Dim ws As Worksheet: Set ws = SourceFirstCell.Worksheet
Dim slCell As Range
Set slCell = ws.Cells(ws.Rows.Count, SourceFirstCell.Column).End(xlUp)
If slCell.Row < SourceFirstCell.Row Then Exit Sub ' no data
Dim srg As Range: Set srg = ws.Range(SourceFirstCell, slCell)
Dim TestWert As Double: TestWert = ws.Range(TestCellAddress).Value
Dim k As Long: k = 1
Dim sCell As Range
For Each sCell In srg.Cells
If IsNumeric(sCell) Then
If sCell.Value = TestWert * k Then
ws.Cells(sCell.Row, DestinationColumn).Value = k
k = k + 1
End If
End If
Next sCell
MsgBox "Results written.", vbInformation
End Sub