Look up in row constant occurrences

motilulla · Nov 17, 2017

Hello,

I am looking VBA solution for specific task look up in row constant occurrences

Data got in cells C5:P22, "1" is filled with red colour and white fonts, "X" is filled with dark green colour and white fonts, "2" is filled with blue colour and white fonts,

Results shown in R6 AF22

Example for row 6...
C6 = X count constant occurrence =1, Result cell R6 =1 as it is "X" so fill dark green colour and white fonts

D6 = 1 count constant occurrence =1, Result cell S6 =1 as it is "1" so fill red colour and white fonts

E, F, G 6 = 2 count constant occurrence = 3, Result cell T6 =3 as it is "2" so fill blue colour and white fonts

Book1

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

1

2

3

4

5

P1

P2

P3

P4

P5

P6

P7

P8

P9

P10

P11

P12

P13

P14

P1

P2

P3

P4

P5

P6

P7

P8

P9

P10

P11

P12

P13

P14

P15

6

X

1

2

1

X

1

2

1

3

4

1

2

7

2

1

X

1

X

2

X

1

2

X

2

1

2

1

2

1

8

X

1

2

1

2

X

1

2

X

1

2

1

2

1

3

1

9

2

1

X

2

X

1

X

1

2

X

2

1

2

1

10

1

2

X

1

X

1

X

1

2

1

4

1

3

1

11

1

2

X

1

2

1

2

1

2

1

2

4

12

X

1

2

X

2

1

X

2

1

2

4

1

13

2

1

2

1

X

1

2

1

2

1

5

1

2

14

1

2

1

2

1

2

1

5

1

4

15

2

X

2

1

X

1

X

1

2

1

3

1

2

1

16

1

2

1

2

X

1

X

1

3

1

4

1

2

17

2

1

2

X

2

X

1

X

1

X

2

1

3

1

18

2

1

X

1

2

1

X

1

X

1

2

1

2

1

2

1

19

X

2

1

2

1

2

X

1

5

1

4

1

20

1

2

1

2

1

X

2

X

1

2

1

4

2

1

21

X

1

13

1

22

1

X

1

6

1

7

23

24

Sheet5

Resume: count constant occurrence and after counts, result colour cells as per filled in data range

Thank you all
Excel 2000
Regards,
Moti

steve the fish · Nov 17, 2017

Try this:

Code:

Dim rngx As Range, rng1 As Range, rng2 As Range, c As Range
Dim lr As Long, a As Long, b As Long, i As Long, j As Long

'get last row of data
lr = Range("C" & Rows.Count).End(xlUp).Row
If lr < 6 Then Exit Sub

'clean up results section
With Range("R6:AF" & lr)
    .ClearContents
    .Interior.ColorIndex = xlNone
    .Font.Color = vbBlack
End With

'colour cells in data section
For Each c In Range("C6:P" & lr)
    c.Interior.ColorIndex = xlNone
    c.Font.Color = vbBlack
    Select Case c.Value
        Case "X"
            If Not rngx Is Nothing Then
                Set rngx = Union(rngx, c)
            Else
                Set rngx = c
            End If
        Case 1
            If Not rng1 Is Nothing Then
                Set rng1 = Union(rng1, c)
            Else
                Set rng1 = c
            End If
        Case 2
            If Not rng2 Is Nothing Then
                Set rng2 = Union(rng2, c)
            Else
                Set rng2 = c
            End If
    End Select
Next

If Not rngx Is Nothing Then
    With rngx.Cells
        .Font.Color = vbWhite
        .Interior.ColorIndex = 50
    End With
End If
If Not rng1 Is Nothing Then
    With rng1.Cells
        .Font.Color = vbWhite
        .Interior.Color = vbRed
    End With
End If
If Not rng2 Is Nothing Then
    With rng2.Cells
        .Font.Color = vbWhite
        .Interior.Color = vbBlue
    End With
End If

'loop through data section to colour results section
a = 1

For i = 6 To lr 'rows 6 to last row of data
    b = 1
    For j = 3 To 16 'columns C to P
        If Cells(i, j) = Cells(i, j + 1) Then
            a = a + 1
        Else
            With Cells(i, 17 + b)
                .Value = a
                .Font.Color = Cells(i, j).Font.Color
                .Interior.Color = Cells(i, j).Interior.Color
            End With
            a = 1
            b = b + 1
        End If
    Next
Next

MickG · Nov 17, 2017

Another option:-

Code:

[COLOR="Navy"]Sub[/COLOR] MG17Nov56
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, R [COLOR="Navy"]As[/COLOR] Range, ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("C6", Range("C" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]For[/COLOR] ac = 0 To 13
        [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Offset(, ac).Value) [COLOR="Navy"]Then[/COLOR]
            .Add Dn.Offset(, ac).Value, Dn.Offset(, ac)
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]Set[/COLOR] .Item(Dn.Offset(, ac).Value) = _
            Union(.Item(Dn.Offset(, ac).Value), Dn.Offset(, ac))
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] ac
ReDim Ray(1 To 14, 1 To 2)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] .Item(K).Areas
       Ray(R(1).Column - 2, 1) = R.Count
       Ray(R(1).Column - 2, 2) = R.Interior.ColorIndex
    [COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]Next[/COLOR] K
.RemoveAll
c = 0
[COLOR="Navy"]For[/COLOR] n = 1 To 14
    [COLOR="Navy"]If[/COLOR] Not IsEmpty(Ray(n, 1)) [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        Dn.Offset(, 14 + c) = Ray(n, 1)
        Dn.Offset(, 14 + c).Interior.ColorIndex = Ray(n, 2)
        Dn.Offset(, 14 + c).Font.ColorIndex = 2
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

motilulla · Nov 17, 2017

steve the fish said:
Try this:

Thanks steve the fish, I like the macro because it fill colours both side in the data and results cells.

Regards,
Moti

motilulla · Nov 17, 2017

MickG said:
Another option:-Regards Mick

Thanks MickG, I like your code, but I am sorry for my mistake not telling in the opening post about that data side column C:P colours were reflected by conditional format, so after running your code it gives perfect counts, as the fonts colour is white, which I can see highlighting the results area by mouse.

Please could you modify the code so it can fill the colours as described for 1 X & 2 in the result area, even if the data area is not filled with colours? I mean if it is simple with white background and black fonts.

Regards,
Moti

MickG · Nov 17, 2017

Try this:-

Code:

[COLOR="Navy"]Sub[/COLOR] MG17Nov19
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, R [COLOR="Navy"]As[/COLOR] Range, ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("C6", Range("C" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] Rng.Offset(, 15).Resize(, 14)
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 2
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]For[/COLOR] ac = 0 To 13
        [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Offset(, ac).Value) [COLOR="Navy"]Then[/COLOR]
            .Add Dn.Offset(, ac).Value, Dn.Offset(, ac)
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]Set[/COLOR] .Item(Dn.Offset(, ac).Value) = _
            Union(.Item(Dn.Offset(, ac).Value), Dn.Offset(, ac))
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] ac
[COLOR="Navy"]Dim[/COLOR] t
ReDim Ray(1 To 14, 1 To 2)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] .Item(K).Areas
       t = R.Address
       [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] R(1).Value
        [COLOR="Navy"]Case[/COLOR] "X": col = 10
        [COLOR="Navy"]Case[/COLOR] 1: col = 3
        [COLOR="Navy"]Case[/COLOR] 2: col = 5
       [COLOR="Navy"]End[/COLOR] Select
       Ray(R(1).Column - 2, 1) = R.Count
       Ray(R(1).Column - 2, 2) = col
    [COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]Next[/COLOR] K
.RemoveAll
c = 0
[COLOR="Navy"]For[/COLOR] n = 1 To 14
    [COLOR="Navy"]If[/COLOR] Not IsEmpty(Ray(n, 1)) [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        Dn.Offset(, 14 + c) = Ray(n, 1)
        Dn.Offset(, 14 + c).Interior.ColorIndex = Ray(n, 2)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

motilulla · Nov 17, 2017

MickG said:

Try this:-

Code:

[COLOR=navy]Sub[/COLOR] MG17Nov19
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] K [COLOR=navy]As[/COLOR] Variant, R [COLOR=navy]As[/COLOR] Range, ac [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] col [COLOR=navy]As[/COLOR] [COLOR=navy]Integer[/COLOR]
[COLOR=navy]Set[/COLOR] Rng = Range("C6", Range("C" & Rows.Count).End(xlUp))
[COLOR=navy]With[/COLOR] Rng.Offset(, 15).Resize(, 14)
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 2
[COLOR=navy]End[/COLOR] With
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
    [COLOR=navy]For[/COLOR] ac = 0 To 13
        [COLOR=navy]If[/COLOR] Not .Exists(Dn.Offset(, ac).Value) [COLOR=navy]Then[/COLOR]
            .Add Dn.Offset(, ac).Value, Dn.Offset(, ac)
        [COLOR=navy]Else[/COLOR]
            [COLOR=navy]Set[/COLOR] .Item(Dn.Offset(, ac).Value) = _
            Union(.Item(Dn.Offset(, ac).Value), Dn.Offset(, ac))
        [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] ac
[COLOR=navy]Dim[/COLOR] t
ReDim Ray(1 To 14, 1 To 2)
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] R [COLOR=navy]In[/COLOR] .Item(K).Areas
       t = R.Address
       [COLOR=navy]Select[/COLOR] [COLOR=navy]Case[/COLOR] R(1).Value
        [COLOR=navy]Case[/COLOR] "X": col = 10
        [COLOR=navy]Case[/COLOR] 1: col = 3
        [COLOR=navy]Case[/COLOR] 2: col = 5
       [COLOR=navy]End[/COLOR] Select
       Ray(R(1).Column - 2, 1) = R.Count
       Ray(R(1).Column - 2, 2) = col
    [COLOR=navy]Next[/COLOR] R
[COLOR=navy]Next[/COLOR] K
.RemoveAll
c = 0
[COLOR=navy]For[/COLOR] n = 1 To 14
    [COLOR=navy]If[/COLOR] Not IsEmpty(Ray(n, 1)) [COLOR=navy]Then[/COLOR]
        c = c + 1
        Dn.Offset(, 14 + c) = Ray(n, 1)
        Dn.Offset(, 14 + c).Interior.ColorIndex = Ray(n, 2)
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] n
[COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]End[/COLOR] With
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

MickG, this one is very fine!

Thank you very much for your time and for the quick modifications

Have a nice day

Regards,
Moti

MickG · Nov 17, 2017

You're welcome
Thank you for the Feedback !!

Look up in row constant occurrences

motilulla

Well-known Member

Excel Facts

steve the fish

Well-known Member

MickG

MrExcel MVP

motilulla

Well-known Member

motilulla

Well-known Member

MickG

MrExcel MVP

motilulla

Well-known Member

MickG

MrExcel MVP

Similar threads

Forum statistics

Share this page

Look up in row constant occurrences

Well-known Member

Excel Facts

Well-known Member

MrExcel MVP

Well-known Member

Well-known Member

MrExcel MVP

Well-known Member

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock