Check cell value in range, depending on condition copy to another Sheet

Dear all,
I hope someone can help me with my problem.
In my workbook I have 2 Sheets; Sheet1 and Sheet2
In Sheet1 I have the following data:
sheet1.png
If there is a number in the range Q2: Q2 I see this as positive and copy the value to sheet2 in cell S3 as being positive.
Next I want my macro goes to the next range Q3: V3 and performs the same control, if there is a number , then copy the value as positive in sheet2 cell S4.
Further conditions; 1) If there is in sheet1, range Q7: V7 empty cells nothing may be copied and there should be no value in sheet2 cell S8. 2) When in sheet1 range Q9: V9 cells contain only the value ND there should be no value in sheet2 cell S10. After encountering both conditions the macro jumps to next range until all rows filled in columns Q:V are done.
In Sheet2 I have the following data:
sheet2.png
I have made two sub procedures , which are not quite complete. Ultimately I want, if possible, make one sub procedure by combining them.

Sub PosKopie()
Dim i As Integer
i = 2
    Sheets("Sheet2").Select
    Range("S3").Select
    ActiveCell.Range("A1").Select
    Sheets("Sheet1").Select
    Range("Q2:V2").Select
    
    Do While Sheets("Sheet1").Cells(i, 17).Value <> 0  
    If IsNumeric(ActiveCell) Then
    ActiveCell.Copy
    ActiveCell.Offset(1, 0).Select
    Sheets("Sheet2").Select
    ActiveCell.Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Value = "positive"
    ActiveCell.Offset(1, 0).Select
    Sheets("Sheet1").Select
    Else: ActiveCell.Offset(1, 0).Select
    Sheets("Sheet2").Select
    ActiveCell.Offset(1, 0).Select
    Sheets("Sheet1").Select
        End If
    i = i + 1
        Loop
End Sub

Sub LoopRange2() 

    Dim rCell As Range
    Dim rRng As Range

    Set rRng = Sheet1.Range("Q2:V2")

    For Each rCol In rRng.Columns
        For Each rCell In rCol.Rows
            Debug.Print rCell.Address, rCell.Value
            If IsNumeric(rCell.Value) Then
                rCell.Activate
                Selection.Copy
            ElseIf isnotnumeric Then
                Exit For
            End If
          
          Next rCell
        
    Next rCol

End Sub

Thank you in advance,
KemalO