Repeating Numbers in Tabled Data

[cotech_10]

Hi All,


I have created a Table that has 11 Columns and 18 Rows, contained in this Table is number data in each cell. What I would like to do is to create a macro that can calculate
and display the number of repeated numbers in any given grouping of lines and produce the results to the right of the Tabled Data as per Attachment 1.

The macro would require input for any line combinations

I have given (3) such examples to the right of this Table:

1. In this first example I have selected Lines 1 to 3 of this table for analysis.

2. In the second example I have selected Lines 3 to 7 for analysis

3. In the third example I have selected two non consecutive lines being
Lines 8 and 17.


As mentioned the "output data" can be written to the right of the Table as per the attachment with automatic calculations on the following:



1. "No of Repeating Numbers" = This total is simply the total of all numbers appearing in the given line

So for this analysis there are 9 Numbers that have repeated in the line grouping "Lines 1 to 3"

2. "No of offset numbers" = This is the total of the repeated numbers in this line that appear in the "Offsets" Line at E2..K2

If we refer to Lines 1 to 3 analysis out of the 9 repeating numbers there are (4)numbers that appear in the "Offset" range located at E2..K2. they are 45,100,103 & 108

These numbers can be colour coded as per the attachment output.



I look forward in hearing back from someone soon.



Kind Regards

 

[Peter_SSs]

I look forward in hearing back from someone soon.

In most cases it would be sooner if you provided your sample data with XL2BB to make it easier for helpers by not having to manually type out sample data to test with.

I also suggest that you update your Account details (click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

See if this is any use.

Sub Repeats()
  Dim d1 As Object, d2 As Object
  Dim a As Variant, b As Variant, bits As Variant, rws As Variant, cols As Variant, ky As Variant
  Dim r As Range
  Dim i As Long, j As Long, k As Long
  
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  For Each r In Range("E2:K2")
    d2(r.Value) = 1
  Next r
  a = Range("B7", Range("B7").End(xlToRight).End(xlDown)).Value
  cols = Application.Transpose(Application.Transpose(Evaluate("row(1:" & UBound(a, 2) & ")")))
  For Each r In Range("N7", Range("N" & Rows.Count).End(xlUp))
    d1.RemoveAll
    ReDim b(1 To 1, 1 To UBound(a, 2))
    ReDim rws(0 To 0)
    k = 0
    bits = Split(r.Value, ",")
    For i = 0 To UBound(bits)
      For j = Split(bits(i) & "-" & bits(i), "-")(0) To Split(bits(i) & "-" & bits(i), "-")(1)
        ReDim Preserve rws(1 To UBound(rws) + 1)
        rws(UBound(rws)) = j
      Next j
    Next i
    b = Application.Index(a, rws, cols)
    For i = 1 To UBound(b)
      For j = 1 To UBound(b, 2)
        d1(b(i, j)) = d1(b(i, j)) + 1
      Next j
    Next i
    For Each ky In d1.keys
      If d1(ky) = 1 Then
        d1.Remove ky
      ElseIf d2.exists(ky) Then
        d1(ky & "|") = 1
        d1.Remove ky
        k = k + 1
      End If
    Next ky
    If d1.Count > 0 Then
      With r.Offset(, 4).Resize(, d1.Count)
        .Value = d1.keys
        If k > 0 Then
          .SpecialCells(xlConstants, xlTextValues).Interior.Color = vbYellow
          .Replace What:="|", Replacement:="", LookAt:=xlPart
        End If
        .Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight
      End With
    End If
  Next r
End Sub

My sample data and results. Note format of data in column N.

cotech_10 2020-08-12 1.xlsm
	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH
1
2				55	54	28	50	23	71	16
3
4
5
6													Lines
7	99	34	50	41	69	18	42	54	81	54	43		1-3				23	54	68
8	51	23	62	49	68	88	37	30	29	15	53		3-7				8	12	19	28	36	40	43	71	74	80
9	23	58	36	87	48	19	68	74	61	78	17		8,18				90	95
10	80	21	95	7	8	79	71	46	12	12	18		10-11
11	5	71	53	56	22	47	74	75	40	90	74		2,5-8,12,15				8	11	19	28	37	40	41	43	49	50	51	53	64	71	74	90
12	9	63	71	2	43	40	28	98	80	69	42
13	73	28	36	43	94	13	64	35	11	19	8
14	43	95	54	49	97	90	38	40	28	50	14
15	52	96	56	91	66	44	69	7	75	70	50
16	12	13	14	15	16	17	18	19	20	21	22
17	23	24	25	26	27	28	29	30	31	32	33
18	17	51	41	11	28	64	85	50	19	89	37
19	33	77	22	45	24	87	61	38	39	86	59
20	93	52	33	86	26	26	18	35	1	74	84
21	28	70	41	81	74	44	8	41	34	71	31
22	80	16	59	95	25	94	12	98	63	60	90
23	57	25	86	8	44	76	25	38	40	53	27
24	58	21	8	89	12	65	90	23	95	84	44
25
Sheet1

 

[cotech_10]

Hi Peter,

Thank you for your quick response... it is greatly appreciated. I have installed the add-in "XL2BB"as suggested.

I have attempted to run the code and encountered a run-time error as per attachment.

Look forward in hearing back from you..


Thanks and Regards

 

[Peter_SSs]

encountered a run-time error as per attachment.

It is good that you showed what line the error occurred on but always best to also give the whole error message.

Do you have an entry something like one of these in column N? That is, a comma or dash without a number following it?
4-
3--7
6,

If still unresolved, could you post with XL2BB the sample data that you were using when the error occurred?

 

[cotech_10]

Hi Peter,

Thanks for your reply... I am sending you the sample data that I had created for this analysis.. as follows:

PMacros.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK	AL	AM	AN	AO	AP	AQ	AR	AS	AT	AU
1
2			Offsets:		340	103	63	108	45	392	100
3
4
5		Col 1	Col 2	Col 3	Col 4	Col 5	Col 6	Col 7	Col 8	Col 9	Col 10	Col 11		Output Analysis :		No of Repeating Numbers	No of offset numbers	Output Data
6	Line No:
7	1	1	5	10	15	108	25	106	35	35	45	50		Lines: 1 - 3		9	4	10	15	35	45	100	103	106	108	240
8	2	43	6	100	101	102	103	104	105	106	45	108		Lines: 3 - 7		18	2	6	7	8	9	10	11	12	14	15	17	21	33	40	99	100	102	103	240
9	3	99	240	240	8	9	10	100	12	103	14	15		Lines: 8 & 17		5	3	103	108	231	392	454
10	4	6	8	34	99	7	21	11	40	102	105	17		etc
11	5	5	9	36	100	6	7	6	8	8	33	33		etc
12	6	43	10	38	101	11	103	15	48	106	7	8		etc
13	7	21	11	40	102	11	12	13	14	15	16	17		etc
14	8	100	800	392	103	102	103	231	392	106	392	99
15	9	101	13	44	104	6	7	6	8	8	33	33
16	10	102	14	46	105	3	6	9	12	15	18	105
17	11	103	15	48	106	7	21	11	40	102	105	17
18	12	104	16	50	107	16	17	18	19	20	21	22
19	13	105	17	52	108	13	105	17	52	108	2	3
20	14	106	18	54	109	190	191	190	192	14	106	3
21	15	107	19	56	110	11	103	15	48	106	7	1
22	16	108	20	58	111	6	7	6	8	8	33	33
23	17	109	108	60	112	231	232	234	454	466	108	454
24	18	110	22	62	113	16	17	18	19	20	21	22
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Sheet1

When I run the macro there is no output produced to the right hand side of the Table.
I immediately receive the run-time error 13 Type mismatch error and option to either
End or Debug. When I select the option to debug it navigates to the vba script and that is
the line causing the issue is highlighted in yellow.

I have attempted to send the whole of the error message but in this there is only one line
marked yellow...


Once again thanking you in your help.



Regards


the line that is marked yellow

 

[Peter_SSs]

I am sending you the sample data that I had created for this analysis.. as follows

In post #2 I said ..

Note format of data in column N.

You need to do that, & use the format I did for specifying the lines of interest.

 

[cotech_10]

Hi Peter,

Also I thought I would bring to your attention if you could look at the sum totals for columns P & Q :
1. Sum total of the Number of repeating numbers
2. Sum total of Numbers in a given line matching the Offset numbers

Thanks and Regards

 

[Peter_SSs]

Also I thought I would bring to your attention if you could look at the sum totals for columns P & Q :
1. Sum total of the Number of repeating numbers
2. Sum total of Numbers in a given line matching the Offset numbers

Sorry, I had intended to return to those & forgot. I will have a look at that now.

 

[Peter_SSs]

if you could look at the sum totals for columns P & Q :
1. Sum total of the Number of repeating numbers
2. Sum total of Numbers in a given line matching the Offset numbers

Try this version

Sub Repeats_v2()
  Dim d1 As Object, d2 As Object
  Dim a As Variant, b As Variant, bits As Variant, rws As Variant, cols As Variant, ky As Variant
  Dim r As Range
  Dim i As Long, j As Long, k As Long
  
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  For Each r In Range("E2:K2")
    d2(r.Value) = 1
  Next r
  a = Range("B7", Range("B7").End(xlToRight).End(xlDown)).Value
  cols = Application.Transpose(Application.Transpose(Evaluate("row(1:" & UBound(a, 2) & ")")))
  For Each r In Range("N7", Range("N" & Rows.Count).End(xlUp))
    If Len(r.Value) > 0 Then
      d1.RemoveAll
      ReDim b(1 To 1, 1 To UBound(a, 2))
      ReDim rws(0 To 0)
      k = 0
      bits = Split(r.Value, ",")
      For i = 0 To UBound(bits)
        For j = Split(bits(i) & "-" & bits(i), "-")(0) To Split(bits(i) & "-" & bits(i), "-")(1)
          ReDim Preserve rws(1 To UBound(rws) + 1)
          rws(UBound(rws)) = j
        Next j
      Next i
      b = Application.Index(a, rws, cols)
      For i = 1 To UBound(b)
        For j = 1 To UBound(b, 2)
          d1(b(i, j)) = d1(b(i, j)) + 1
        Next j
      Next i
      For Each ky In d1.keys
        If d1(ky) = 1 Then
          d1.Remove ky
        ElseIf d2.exists(ky) Then
          d1(ky & "|") = 1
          d1.Remove ky
          k = k + 1
        End If
      Next ky
      r.Offset(, 2).Value = d1.Count
      r.Offset(, 3).Value = k
      If d1.Count > 0 Then
        With r.Offset(, 4).Resize(, d1.Count)
          .Value = d1.keys
          If k > 0 Then
            .SpecialCells(xlConstants, xlTextValues).Interior.Color = vbYellow
            .Replace What:="|", Replacement:="", LookAt:=xlPart
          End If
          .Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight
        End With
      End If
    End If
  Next r
End Sub

cotech_10 2020-08-12 1.xlsm
	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH
1
2				55	54	28	50	23	71	16
3
4
5
6													Lines		Repeats	Offsets
7	99	34	50	41	69	18	42	54	81	54	43		1-3		3	2	23	54	68
8	51	23	62	49	68	88	37	30	29	15	53		3-7		10	2	8	12	19	28	36	40	43	71	74	80
9	23	58	36	87	48	19	68	74	61	78	17		8,18		2	0	90	95
10	80	21	95	7	8	79	71	46	12	12	18
11	5	71	53	56	22	47	74	75	40	90	74		2 , 5 - 8,12,15		16	3	8	11	19	28	37	40	41	43	49	50	51	53	64	71	74	90
12	9	63	71	2	43	40	28	98	80	69	42		10-11		0	0
13	73	28	36	43	94	13	64	35	11	19	8
14	43	95	54	49	97	90	38	40	28	50	14
15	52	96	56	91	66	44	69	7	75	70	50
16	12	13	14	15	16	17	18	19	20	21	22
17	23	24	25	26	27	28	29	30	31	32	33
18	17	51	41	11	28	64	85	50	19	89	37
19	33	77	22	45	24	87	61	38	39	86	59
20	93	52	33	86	26	26	18	35	1	74	84
21	28	70	41	81	74	44	8	41	34	71	31
22	80	16	59	95	25	94	12	98	63	60	90
23	57	25	86	8	44	76	25	38	40	53	27
24	58	21	8	89	12	65	90	23	95	84	44
25
Sheet1

 

[cotech_10]

Hi Peter,

Amazing effort, it works exactly as specified and I took into consideration the formatting in Column "N" ..
Thanking you in your generosity and assistance...

Regards