Help with VBA Code modification

[togenmoser]

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

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 18
        '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

 

[Micron]

Try as I might, I can't see exactly where you get the pairs from that give you those results. Best I can say at this point is that wherever that is, I might branch off by calling a function that looks something like

Private Function CalculatePairs(pair1 As Long, pair2 As Long) As Boolean
Select Case Abs(pair1-pair2)
    Case 1,2,3,5,7
         CalculatePairs = True
    Case Else
         CalculatePairs = False
End Select

The call might come after 'Check if criteria values are opposite of each other
and might look like
CalculatePairs pairValue1, pairValue2
or
If CalculatePairs pairValue1, pairValue2 = True Then 'do something if True, something else if False
EDIT - Note that ABS function converts negative values to positive, so since you are concerned with both, converting -1 to 1 is basically the same situation as converting +1 to +1 (which it doesn't - I'm just trying to explain the outcome of using ABS)
HTH

 

[togenmoser]

Try as I might, I can't see exactly where you get the pairs from that give you those results. Best I can say at this point is that wherever that is, I might branch off by calling a function that looks something like

Private Function CalculatePairs(pair1 As Long, pair2 As Long) As Boolean
Select Case Abs(pair1-pair2)
    Case 1,2,3,5,7
         CalculatePairs = True
    Case Else
         CalculatePairs = False
End Select

The call might come after 'Check if criteria values are opposite of each other
and might look like
CalculatePairs pairValue1, pairValue2
or
If CalculatePairs pairValue1, pairValue2 = True Then 'do something if True, something else if False

HTH

Please check this and help edit the code

SUNDAY SPECIAL.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S
1		60	56	53	39	75		116	113	99	135	109		95	131	92	128	114
2
3		3	63	30	89	58		34	24	65	37	48		65	82	61	23	75
4		14	31	7	24	54		61	12	24	50	53		45	68	21	32	7
5		22	17	8	52	34		67	24	41	22	3		43	64	51	2	19
6		29	87	60	26	20		23	20	37	12	34		13	16	17	87	44
7		24	38	32	4	50		69	25	72	30	67		74	10	57	33	89
8		5	25	12	31	53		82	11	49	67	70		4	71	25	16	11
9		50	41	83	75	22		80	27	66	17	50		74	13	24	43	4
10		84	10	89	13	19		41	76	5	51	33		63	87	19	57	49
11		17	9	70	12	88		89	35	14	7	63		83	55	56	31	8
12		17	69	53	90	22		37	53	18	35	60		65	81	44	68	12
13		5	63	51	49	33		20	58	75	62	31		42	20	58	24	30
14		63	37	22	11	14		69	39	62	76	9		34	88	13	17	83
15		30	86	62	37	52		14	33	34	73	49		42	73	33	31	63
16		27	40	11	69	7		62	54	6	37	2		79	4	30	31	83
17		81	19	60	16	5		30	27	47	83	18		29	45	59	32	27
18		28	2	71	53	33		73	9	51	14	4		9	74	47	14	8
19		59	18	6	81	69		11	30	7	20	25		37	34	41	67	43
20		18	79	69	61	16		54	77	5	71	76		36	39	8	15	88
21		60	6	57	80	50		81	47	32	84	2		87	66	46	30	26
22		89	20	55	53	60		65	6	85	71	29		15	78	55	20	88
23		61	25	55	47	16		25	23	18	62	63		27	23	67	50	35
24		49	88	85	44	74		57	10	58	29	1		53	37	13	69	4
25		65	2	86	50	57		5	32	36	28	56		90	61	37	89	20
26		63	19	45	16	61		8	63	35	27	6		2	53	88	78	64
27		56	82	34	11	49		87	4	23	59	29		37	48	71	42	45
28		2	71	61	48	79		3	70	17	46	12		75	85	69	15	43
29		2	49	13	23	28		37	64	61	42	80		30	87	78	44	89
30		24	23	61	21	44		18	58	19	36	5		68	62	29	48	47
31		36	79	27	11	19		58	79	21	14	20		80	27	53	40	44
32		88	74	45	8	52		32	60	59	5	56		43	61	76	75	67
33		49	31	55	68	86		62	59	86	89	75		68	32	22	79	60
34		82	83	85	37	33		35	75	21	31	78		4	6	39	63	8
35		89	39	3	79	7		78	36	30	13	45		70	83	73	85	66
36		54	53	18	1	57		30	69	14	9	38		66	71	37	65	58
37		24	60	67	3	34		30	83	20	36	70		49	19	67	75	11
38		24	26	82	83	43		50	84	7	55	83		76	28	29	88	84
39		31	21	17	77	75		53	51	35	42	8		7	74	24	58	57
40		16	70	6	80	40		55	33	52	41	42		69	16	49	85	63
41		90	11	63	21	19		6	58	79	23	29		34	7	55	28	70
42		82	23	4	72	16		32	35	44	11	38		14	13	20	12	17
43		21	73	13	22	9		75	26	30	38	50		23	61	12	54	15
44		48	73	52	39	70		20	9	87	19	36		59	36	4	83	65
45		50	76	15	10	34		1	85	21	34	16		30	34	53	52	55
46		66	60	40	73	3		47	89	12	63	40		87	75	31	34	7
47		31	3	90	77	21		25	87	12	30	75		26	90	28	47	61
48		75	56	13	58	28		76	37	58	18	53		87	30	7	57	62
49		3	14	58	2	73		56	72	39	29	37		55	44	33	51	30
50		15	23	58	21	6		36	49	37	16	68		22	70	48	38	37
51		78	19	88	58	21		3	35	18	66	47		7	71	34	31	69
52		87	56	58	48	66		49	44	13	2	12		38	26	39	43	68
53		55	2	37	34	12		80	56	35	53	16		2	78	64	77	85
54		77	33	80	56	63		82	74	27	38	60		59	34	54	57	21
55		51	72	3	43	42		15	80	68	62	48		76	83	26	38	7
56		7	34	17	18	27		38	56	70	72	59		52	14	53	67	44
57		50	5	32	10	42		38	89	13	41	83		42	26	39	54	11
58		69	10	3	71	42		10	48	40	86	55		41	61	3	2	74
59		84	29	58	61	81		90	65	62	25	83		17	56	32	68	65
60		83	2	80	38	47		81	34	71	69	58		89	77	46	88	66
61		71	83	6	25	82		43	16	28	69	73		75	57	28	31	11
62		84	21	24	88	9		65	58	50	15	32		15	1	65	57	80
63		81	90	3	14	1		89	75	51	50	17		18	30	17	3	85
64		72	79	22	27	11		30	77	35	75	46		27	12	75	45	23
65		77	79	78	81	15		11	59	2	51	69		49	14	4	63	76
66		60	56	62	87	83		82	45	22	6	47		84	77	12	69	18
67		7	82	53	33	76		27	60	5	73	56		81	75	40	44	2
68		5	54	33	9	52		41	16	55	28	25		48	29	73	68	40
69		21	28	61	75	27		49	82	74	60	3		48	70	2	59	25
70		22	38	25	17	81		87	41	22	74	56		29	36	68	37	38
71		48	79	18	38	25		29	64	35	43	36		53	87	38	88	39
72		31	47	59	34	53		81	20	21	76	5		8	25	30	88	85
73		89	64	68	16	78		14	86	22	78	32		16	20	55	81	65
74		48	32	49	10	38		17	35	33	13	2		14	88	80	2	34
75		53	8	45	37	24		17	33	13	52	15		41	55	40	33	32
76		15	75	66	39	28		33	32	35	50	54		15	61	86	6	88
77		86	63	74	28	69		16	3	53	39	14		12	54	43	41	45
SUN SPEC

Cell Formulas
Range	Formula
H1	H1	=SUM(B1,C1)
I1	I1	=SUM(B1,D1)
J1	J1	=SUM(B1,E1)
K1	K1	=SUM(B1,F1)
L1	L1	=SUM(C1,D1)
N1	N1	=SUM(C1,E1)
O1	O1	=SUM(C1,F1)
P1	P1	=SUM(D1,E1)
Q1	Q1	=SUM(D1,F1)
R1	R1	=SUM(E1,F1)

Named Ranges
Name	Refers To	Cells
'SUN SPEC'!Print_Area	='SUN SPEC'!$C$1:$BC$106	N1:O1, L1, H1

 

[togenmoser]

Let me explain further. The code is to make Excel find all two cells in the same row that has sum total equal to any of the cells in H1 to R1. The cells must have value differences of +1,+2,+3,+4, and +7 and then -1,-2,-3,-5 and -7 of any two cells in B1 to F1. The cells that makes a pair should have value differences opposite of each other. Example; Cells D15 and E15 have values of 62 and 37 respectively. Which are +2 and -2 of cells B1 and E1 whose values are 60-39 respectively. Cells D15 and E15 has sum value of 99 which equals the sum value of cell J1.

Now I want Excel to find only cells with the difference of : +1 and -1, +2 and -2, +3 and -3, +5 and -5 and the +7 and -7 of any two cells in B1 to F1 and sum up to any of the target cells in H1 to R1.