Comparing sets of data with a number (lower and upper limit) --part2

Option Explicit
Option Base 1
 
Sub aspecialmacro()
Dim rng As Range
Dim celle As Range
Dim rowe As Long
Dim coll As New Collection
Dim k As Long, i As Long, n As Long, m As Long
Dim temp As Double
Dim myarray(7) As Double
Dim str As String
 
Application.ScreenUpdating = False
 
With Sheets("Sheet1")
    For i = 3 To .Cells(.Cells.Rows.Count, "Y").End(xlUp).Row
        On Error Resume Next
        k = 1
        Set rng = Range(.Cells(i, "Y"), .Cells(i, "AE"))
        For Each celle In rng
            myarray(k) = celle
            k = k + 1
        Next celle
        
        temp = 0
        For m = 1 To 7
            For n = 1 To 7
            If myarray(m) < myarray(n) Then
                temp = myarray(m)
                myarray(m) = myarray(n)
                myarray(n) = temp
                If n = 7 Then
                    myarray(7) = temp
                End If
                temp = 0
            End If
            Next n
        Next m
            
        k = 1
        temp = 0
        Do While myarray(k) < .[AF2]
            temp = myarray(k)
            k = k + 1
            If k > 7 Then Exit Do
        Loop
        
        For m = 1 To 7
            myarray(m) = 0
        Next m
        
        .Cells(i, "AH") = temp
        For m = 25 To 31
            If .Cells(i, m) = temp Then
                .Cells(i, "AI") = .Cells(1, m)
            End If
        Next m
    Next i
    
End With
 
Application.ScreenUpdating = True
 
End Sub

                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:

Dim strWorkbookName As String
Dim wbkCurrent As Workbook
 
strWorkbookName = InputBox("Enter the workbook path\name") 
If Len(strWorkbookName) = 0 Then
  Exit Sub
End If
 
strWorkbookName = InputBox("Enter workbook path\name")
Workbooks.Open strWorkbookName 
Set wbkCurrent = ActiveWorkbook
With wbkCurrent 
  With .Sheets("Sheet1")
 
   'add your processing code here
 
  End With
End With
                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:

Option Explicit
Option Base 1
 
Sub aspecialmacro()
 
Dim strWorkbookName As String
Dim wbkCurrent As Workbook
 
strWorkbookName = InputBox("Enter the workbook path\name")
If Len(strWorkbookName) = 0 Then
  Exit Sub
End If
 
strWorkbookName = InputBox("Enter workbook path\name")
Workbooks.Open strWorkbookName
Set wbkCurrent = ActiveWorkbook
With wbkCurrent
  With .Sheets("Sheet1")
 
Application.ScreenUpdating = False
 
With Sheets("Sheet1")
    For i = 3 To .Cells(.Cells.Rows.Count, "Y").End(xlUp).Row
        On Error Resume Next
        k = 1
        Set rng = Range(.Cells(i, "AA"), .Cells(i, "AH"))
        For Each celle In rng
            myarray(k) = celle
            k = k + 1
        Next celle
        
        temp = 0
        For m = 1 To 7
            For n = 1 To 7
            If myarray(m) < myarray(n) Then
                temp = myarray(m)
                myarray(m) = myarray(n)
                myarray(n) = temp
                If n = 7 Then
                    myarray(7) = temp
                End If
                temp = 0
            End If
            Next n
        Next m
            
        k = 1
        temp = 0
        Do While myarray(k) < .[AI2]
            temp = myarray(k)
            k = k + 1
            If k > 7 Then Exit Do
        Loop
        
        For m = 1 To 7
            myarray(m) = 0
        Next m
        
        .Cells(i, "AH") = temp
        For m = 25 To 31
            If .Cells(i, m) = temp Then
                .Cells(i, "AI") = .Cells(1, m)
            End If
        Next m
    Next i
    
End With
 
Application.ScreenUpdating = True
 
End Sub
                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:

Option Explicit
Option Base 1
 
Sub aspecialmacro()
Dim rng As Range
Dim celle As Range
Dim rowe As Long
Dim coll As New Collection
Dim k As Long, i As Long, n As Long, m As Long
Dim temp As Double
Dim myarray(8) As Double
Dim str As String
 
Application.ScreenUpdating = False
 
With Sheets("Sheet1")
    For i = 2 To .Cells(.Cells.Rows.Count, "AA").End(xlUp).Row
        On Error Resume Next
        k = 1
        Set rng = Range(.Cells(i, "AA"), .Cells(i, "AH"))
        For Each celle In rng
            myarray(k) = celle
            k = k + 1
        Next celle
        
        temp = 0
        For m = 1 To 8
            For n = 1 To 8
            If myarray(m) < myarray(n) Then
                temp = myarray(m)
                myarray(m) = myarray(n)
                myarray(n) = temp
                If n = 8 Then
                    myarray(8) = temp
                End If
                temp = 0
            End If
            Next n
        Next m
            
        k = 1
        temp = 0
        Do While myarray(k) < 1 '.Cells(i, "AI")
            temp = myarray(k)
            k = k + 1
            If k > 8 Then Exit Do
        Loop
        .Cells(i, "AI") = temp
                
        For m = 27 To 34
            If .Cells(i, m) = temp Then
                .Cells(i, "AJ") = .Cells(1, m)
            End If
        Next m
        
        For m = 1 To 8
            myarray(m) = 0
        Next m
    Next i
    
End With
 
End Sub

                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:

   Sub FindClosest()
    Const CONDITION_NUMBER = 1
    Const COLUMNS_OF_DATA = 7
    
    Dim intCount As Integer
    Dim sngNums() As Single
    ReDim sngNums(COLUMNS_OF_DATA)
    Dim sngMinDiff As Single
    Dim sngTemp As Single
    Dim intResult As Integer
    Dim strTemp As String
    Dim lngRow As Long
    Dim strRow As String
    Dim lngBottom As Long
    
    If COLUMNS_OF_DATA > 35 Then
        MsgBox "You cannot have more than 35 columns of data to compare."
        Exit Sub
    End If
    
    ActiveCell.SpecialCells(xlLastCell).Select
    lngBottom = ActiveCell.Row
        
    For lngRow = 2 To lngBottom
        strRow = Trim(str(lngRow))
       ' Populate an array with the differences. PURPOSE: TO REDUCE NUMBER OF LOCATIONS
       For intCount = 1 To COLUMNS_OF_DATA
           If intCount < 3 Then
               strTemp = Chr(88 + intCount)
           Else
               strTemp = "A" & Chr(62 + intCount)
           End If
           sngNums(intCount) = CONDITION_NUMBER - Range(strTemp & strRow).Value
       Next
    
       ' Start by finding a value that we know is not right that we can use to work our way in.
       ' Get the larger of the differences from the smallest and largest numbers in the source range
       If COLUMNS_OF_DATA < 3 Then
           strTemp = Chr(88 + COLUMNS_OF_DATA)
       Else
           strTemp = "A" & Chr(62 + COLUMNS_OF_DATA)
       End If
       sngTemp = Abs(CONDITION_NUMBER - (Application.WorksheetFunction.Max(Range("Y" & strRow & ":" & strTemp & strRow))))
       sngMinDiff = Abs(CONDITION_NUMBER - (Application.WorksheetFunction.Min(Range("Y" & strRow & ":" & strTemp & strRow))))
       
       If sngTemp > sngMinDiff Then sngMinDiff = sngTemp
       
       ' Now as we go through the numbers, we know we'll get something that's BIGGER.
       ' Or, if they're all the same, it won't matter which we select.
       intResult = 1
       For intCount = 1 To COLUMNS_OF_DATA
           ' If the abs of the difference is smaller, collect the BIGGER number.
           If Abs(sngNums(intCount)) < sngMinDiff Then
               sngMinDiff = Abs(sngNums(intCount))
               intResult = intCount
           End If
           ' If the abs of the diff is the same, but the original # is lower than the
           ' condition, point to that one instead. RULE OF THUMB: choose nearer to 1 but eg. if btw 0.5 and 1.5, choose 1.5.
           If Abs(sngNums(intCount)) = sngMinDiff And sngNums(intCount) < 0 Then
               intResult = intCount
           End If
       Next
       If intResult < 3 Then
           strTemp = Chr(88 + intResult)
       Else
           strTemp = "A" & Chr(62 + intResult)
       End If
       ' Now intResult holds the index of the closest number that is lower than the condition.
       Range("A" & Chr(63 + COLUMNS_OF_DATA) & strRow).Formula = Range(strTemp & strRow).Value
    Next
End Sub
 
                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72: