Creating a loop to go through each value in range - excel

Question

I have below code in which i want to create a loop for multiple values that are available in Sheet1.Range(A2:A100) code will pick one by one each value and match then paste result in Column B.
thisvalue = Sheet1.Range("A2:A100"). Can someone please help me to create the loop. Your help will be appreciated.
Sub Macro1()
Dim thisvalue As Double, sh As Worksheet, lastR As Long, arr, arrFin, i As Long
thisvalue = 3.61
Set sh = Worksheets("Sheet1")
lastR = sh.Range("J" & sh.rows.count).End(xlUp).row
arr = sh.Range("E7:J" & lastR).Value
ReDim arrFin(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(arr)
If arr(i, 1) < thisvalue And arr(i, 2) > thisvalue Then arrFin(i, 1) = arr(i, 6)
Next i
sh.Range("B2").Resize(UBound(arrFin), 1).Value = arrFin
End Sub

Answer 1

Please, try the next code:
Sub Macro1__2()
Dim thisvalue As Double, sh As Worksheet, lastR As Long
Dim arrVal, arr, arrFin, i As Long, j As Long
Set sh = Worksheets("Sheet2")
arrVal = Worksheets("Sheet1").Range("Q2:Q100").Value
Worksheets("Sheet1").Range("R2:R200").ClearContents
lastR = sh.Range("J" & sh.Rows.Count).End(xlUp).Row
arr = sh.Range("E7:J" & lastR).Value
For j = 1 To UBound(arrVal)
thisvalue = arrVal(j, 1)
If CStr(thisvalue) <> "" Then 'excluding the cases of empty cells. I didn't know that they may exist
arrFin = Worksheets("Sheet1").Range("R2:R200").Value 'firstly input the existing range in the array
For i = 1 To UBound(arr)
If arr(i, 1) < thisvalue And arr(i, 2) > thisvalue Then arrFin(j, 1) = arr(i, 6)
Next i
Worksheets("Sheet1").Range("R2").Resize(UBound(arrFin), 1).Value = arrFin
End If
Next j
MsgBox "Ready..."
End Sub

Answer 2

Ranges and Arrays
Option Explicit
Sub Macro1()
' Source
Const sName As String = "Sheet1"
Const slrCol As String = "J"
Const sCols As String = "E:J"
Const sfRow As Long = 7
Const scColLess As Long = 1
Const scColGreater As Long = 2
Const srCol As Long = 6
Const sCriteria As Double = 3.61
' Destination
Const dName As String = "Sheet1"
Const dFirst As String = "B2"
' Create a reference to the Workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create a reference to the Source Worksheet ('sws').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
' Create a reference to the Source Range ('srg').
If sws.Columns(sCols).Columns.Count < srCol Then Exit Sub ' too few columns
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slrCol).End(xlUp).Row
If slRow < sfRow Then Exit Sub ' no data
Dim rCount As Long: rCount = slRow - sfRow + 1 ' for source and destination
Dim srg As Range
Set srg = sws.Rows(sfRow).Columns(sCols).Resize(rCount)
' Write the values from the Source Range
' to the Source Array ('sData').
Dim sData As Variant: sData = srg.Value
' Define the Destination Array ('dData').
Dim dData As Variant: ReDim dData(1 To rCount, 1 To 1)
' Write the appropriate values from the Source Array
' to the Destination Array.
Dim cValue As Variant
Dim r As Long
For r = 1 To rCount
cValue = sData(r, scColLess)
If IsNumeric(cValue) Then
If cValue < sCriteria Then
cValue = sData(r, scColGreater)
If IsNumeric(cValue) Then
If cValue > sCriteria Then
dData(r, 1) = sData(r, srCol)
End If
End If
End If
End If
Next r
' Create a reference to the Destination Worksheet ('dws').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' Create a reference to the Destination Range ('drg').
Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
Dim drg As Range: Set drg = dfCell.Resize(rCount)
' Write the values from the Destination Array
' to the Destination Range ('drg').
drg.Value = dData
' Clear the Destination Clear Range ('dcrg'),
' the range below the Destination Range.
Dim dcrg As Range
Set dcrg = drg.Resize(dws.Rows.Count - drg.Row - rCount + 1).Offset(rCount)
dcrg.Clear ' or maybe rather 'dcrg.ClearContents'
' Format the Destination Range.
'drg.Font.Bold = True
'drg.EntireColumn.AutoFit
'drg.Interior.Color = 14348258
' Save the workbook.
'wb.Save
End Sub