Help with VBA code error "For variable already in use"

[togenmoser]

Any effort to improve or correct this code will be much appreciated. I get "For variable already in use" error.
The code is pasted below.
Thanks in advance.

Sub FindAllSumPairs()
'Declare variables
Dim ws As Worksheet
Dim rng As Range
Dim i As Long, j As Long, k As Long, m As Long, l As Long
Dim sum As Long
Dim color As Long
Dim prevColor As Long
Dim diff As Double
Dim criteria(1 To 5) As Long
Dim pairValue1 As Long, pairValue2 As Long
Dim criteriaMatch1 As Boolean, criteriaMatch2 As Boolean

'Set worksheet and range
Set ws = ActiveSheet
Set rng = ws.UsedRange 'Change this as needed

'Get criteria values from B1 to F1
For i = 1 To 5
criteria(i) = ws.Cells(1, i + 1).Value
Next i

'Loop through the target values in H1 to Q1
For i = 8 To 17
'Get the target value and a random color
sum = ws.Cells(1, i).Value
color = RGB(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256))

'Check if the chosen color is too close to the previous color
If i > 8 Then
'Get the previous color
prevColor = ws.Cells(1, i - 1).Interior.Color

'Calculate the difference between the two colors using Euclidean distance formula
diff = Sqr(((color Mod 256) - (prevColor Mod 256)) ^ 2 + ((color \ 256 Mod 256) - (prevColor \ 256 Mod 256)) ^ 2 + ((color \ 65536) - (prevColor \ 65536)) ^ 2)

'If the difference is less than a threshold, choose a different color
If diff < 50 Then 'Change this as needed
color = RGB(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256))
End If
End If

'Loop through the rows in the range
For j = 2 To rng.Rows.Count 'Start from row 2 to avoid the header
'Loop through the sets of 5 cells in the same row, separated by empty cells
For m = 1 To rng.Columns.Count Step 6
'Loop through the columns in the same set of 5 cells
For k = m To m + 4
'Loop through the remaining columns in the same set of 5 cells
For l = k + 1 To m + 4
'Check if the current cell and another cell are not empty and add up to the target value
If Not IsEmpty(rng.Cells(j, k)) And Not IsEmpty(rng.Cells(j, l)) And rng.Cells(j, k).Value + rng.Cells(j, l).Value = sum Then
pairValue1 = rng.Cells(j, k).Value
pairValue2 = rng.Cells(j, l).Value

'Reset criteria match flags
criteriaMatch1 = False
criteriaMatch2 = False

'Check against criteria for the first cell of the pair
For m = 1 To 5
If pairValue1 >= criteria(m) - 10 And pairValue1 <= criteria(m) + 10 Then
criteriaMatch1 = True
Exit For
End If
Next m

'Check against criteria for the second cell of the pair
For m = 1 To 5
If pairValue2 >= criteria(m) - 10 And pairValue2 <= criteria(m) + 10 Then
criteriaMatch2 = True
Exit For
End If
Next m

'Check if criteria values are opposite of each other
If criteriaMatch1 And Not criteriaMatch2 Then
For m = 1 To 5
If pairValue2 = criteria(m) + 10 Then
criteriaMatch2 = True
Exit For
End If
Next m
ElseIf criteriaMatch2 And Not criteriaMatch1 Then
For m = 1 To 5
If pairValue1 = criteria(m) - 10 Then
criteriaMatch1 = True
Exit For
End If
Next m
End If

'If both criteria are met, format the cells
If criteriaMatch1 And criteriaMatch2 Then
'Set the border color and thickness for the pair of cells, using all round borders
With rng.Cells(j, k).Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Color = color
.Weight = xlThick
End With

With rng.Cells(j, k).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Color = color
.Weight = xlThick
End With

With rng.Cells(j, l).Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Color = color
.Weight = xlThick
End With

With rng.Cells(j, l).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Color = color
.Weight = xlThick
End With

With rng.Cells(j, k).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Color = color
.Weight = xlThick
End With

With rng.Cells(j, k).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Color = color
.Weight = xlThick
End With

With rng.Cells(j, l).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Color = color
.Weight = xlThick
End With

With rng.Cells(j, l).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Color = color
.Weight = xlThick
End With

End If
End If
Next l
Next k
Next m
Next j
Next i
End Sub

 

[MARK858]

T



Thanks very much. The code is working now but I'd doesn't seem to follow the set criteria entirely.
Cells u13, w13 and x 13 are not within the criteria range but it's been formatted.
There are still other cells that are out of the criteria range but has been formatted.

I am afraid the criteria is something you will need to look at as I will be finishing for the day soon (and being honest I don't want to go through it anyway)

 

[togenmoser]

I am afraid the criteria is something you will need to look at as I will be finishing for the day soon (and being honest I don't want to go through it anyway)

Alright Sir, I really appreciate your help and time. Can't thank you enough. I am grateful
Thanks once again

 

[MARK858]

You're welcome

 

[togenmoser]

Try...

Sub FindAllSumPairs()
    'Declare variables
    Dim ws As Worksheet
    Dim rng As Range
    Dim i As Long, j As Long, k As Long, m As Long, l As Long
    Dim sum As Long, xx As Long, yy As Long, zz As Long
    Dim color As Long
    Dim prevColor As Long
    Dim diff As Double
    Dim criteria(1 To 5) As Long
    Dim pairValue1 As Long, pairValue2 As Long
    Dim criteriaMatch1 As Boolean, criteriaMatch2 As Boolean

    'Set worksheet and range
    Set ws = ActiveSheet
    Set rng = ws.UsedRange                       'Change this as needed

    'Get criteria values from B1 to F1
    For i = 1 To 5
        criteria(i) = ws.Cells(1, i + 1).Value
    Next i

    'Loop through the target values in H1 to Q1
    For i = 8 To 17
        'Get the target value and a random color
        sum = ws.Cells(1, i).Value
        color = RGB(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256))

        'Check if the chosen color is too close to the previous color
        If i > 8 Then
            'Get the previous color
            prevColor = ws.Cells(1, i - 1).Interior.color

            'Calculate the difference between the two colors using Euclidean distance formula
            diff = Sqr(((color Mod 256) - (prevColor Mod 256)) ^ 2 + ((color \ 256 Mod 256) - (prevColor \ 256 Mod 256)) ^ 2 + ((color \ 65536) - (prevColor \ 65536)) ^ 2)

            'If the difference is less than a threshold, choose a different color
            If diff < 50 Then                    'Change this as needed
                color = RGB(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256))
            End If
        End If

        'Loop through the rows in the range
        For j = 2 To rng.Rows.Count              'Start from row 2 to avoid the header
            'Loop through the sets of 5 cells in the same row, separated by empty cells
            For m = 1 To rng.Columns.Count Step 6
                'Loop through the columns in the same set of 5 cells
                For k = m To m + 4
                    'Loop through the remaining columns in the same set of 5 cells
                    For l = k + 1 To m + 4
                        'Check if the current cell and another cell are not empty and add up to the target value
                        If Not IsEmpty(rng.Cells(j, k)) And Not IsEmpty(rng.Cells(j, l)) And rng.Cells(j, k).Value + rng.Cells(j, l).Value = sum Then
                            pairValue1 = rng.Cells(j, k).Value
                            pairValue2 = rng.Cells(j, l).Value

                            'Reset criteria match flags
                            criteriaMatch1 = False
                            criteriaMatch2 = False

                            'Check against criteria for the first cell of the pair
                            For xx = 1 To 5
                                If pairValue1 >= criteria(xx) - 10 And pairValue1 <= criteria(xx) + 10 Then
                                    criteriaMatch1 = True
                                    Exit For
                                End If
                            Next xx

                            'Check against criteria for the second cell of the pair
                            For yy = 1 To 5
                                If pairValue2 >= criteria(yy) - 10 And pairValue2 <= criteria(yy) + 10 Then
                                    criteriaMatch2 = True
                                    Exit For
                                End If
                            Next yy

                            'Check if criteria values are opposite of each other
                            If criteriaMatch1 And Not criteriaMatch2 Then
                                For zz = 1 To 5
                                    If pairValue2 = criteria(zz) + 10 Then
                                        criteriaMatch2 = True
                                        Exit For
                                    End If
                                Next zz
                            ElseIf criteriaMatch2 And Not criteriaMatch1 Then
                                For zz = 1 To 5
                                    If pairValue1 = criteria(zz) - 10 Then
                                        criteriaMatch1 = True
                                        Exit For
                                    End If
                                Next zz
                            End If

                            'If both criteria are met, format the cells
                            If criteriaMatch1 And criteriaMatch2 Then
                                'Set the border color and thickness for the pair of cells, using all round borders
                                With rng.Cells(j, k).Borders(xlEdgeLeft)
                                    .LineStyle = xlContinuous
                                    .color = color
                                    .Weight = xlThick
                                End With

                                With rng.Cells(j, k).Borders(xlEdgeRight)
                                    .LineStyle = xlContinuous
                                    .color = color
                                    .Weight = xlThick
                                End With

                                With rng.Cells(j, l).Borders(xlEdgeLeft)
                                    .LineStyle = xlContinuous
                                    .color = color
                                    .Weight = xlThick
                                End With

                                With rng.Cells(j, l).Borders(xlEdgeRight)
                                    .LineStyle = xlContinuous
                                    .color = color
                                    .Weight = xlThick
                                End With

                                With rng.Cells(j, k).Borders(xlEdgeTop)
                                    .LineStyle = xlContinuous
                                    .color = color
                                    .Weight = xlThick
                                End With

                                With rng.Cells(j, k).Borders(xlEdgeBottom)
                                    .LineStyle = xlContinuous
                                    .color = color
                                    .Weight = xlThick
                                End With

                                With rng.Cells(j, l).Borders(xlEdgeTop)
                                    .LineStyle = xlContinuous
                                    .color = color
                                    .Weight = xlThick
                                End With

                                With rng.Cells(j, l).Borders(xlEdgeBottom)
                                    .LineStyle = xlContinuous
                                    .color = color
                                    .Weight = xlThick
                                End With

                            End If
                        End If
                    Next l
                Next k
            Next m
        Next j
    Next i
End Sub

Hello, I want a little modification to the code please. I want excel to only find pairs with the value difference of (-1+1, -2+2, -3+3, -5+5, and -7+7) and sum up to the target value.
I will appreciate your help in modifying the code. Thanks in anticipation

 

[MARK858]

Please start a new thread as your request is different to this threads question which was about dealing with the error message.