Require modification in the current VBA

motilulla · Nov 22, 2017

MickG,
MrExcel MVP, Congratulations

Hello,

MickG, please if you could, I need slightly modification in the following macro, that produce the constant occurrence result as follow

If data C:P row start with "1" constant occurrence result start in column R
If data C:P row start with "X" constant occurrence result start in column S
If data C:P row start with "2" constant occurrence result start in column T

Code:

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

This is result getting with the above macro

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

Sheet1

This is what I am looking for shift result as per 1, X or 2

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

Sheet2

Thank you all
Excel 2000
Regards,
Moti

MickG · Nov 22, 2017

Hello Moti,
Thank you for your good wishes.

Try this modified code:-

Code:

[COLOR="Navy"]Sub[/COLOR] MG22Nov42
[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] Dt [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 3)
[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
        [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
       Ray(R(1).Column - 2, 3) = Dt
    [COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]Next[/COLOR] K
.RemoveAll
c = 0
[COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] Dn.Value
    [COLOR="Navy"]Case[/COLOR] "X": Dt = 1
    [COLOR="Navy"]Case[/COLOR] 1: Dt = 0
    [COLOR="Navy"]Case[/COLOR] 2: Dt = 2
[COLOR="Navy"]End[/COLOR] Select
[COLOR="Navy"]For[/COLOR] n = 1 To 14
    [COLOR="Navy"]If[/COLOR] Not IsEmpty(Ray(n, 1)) [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        [COLOR="Navy"]With[/COLOR] Dn.Offset(, 14 + c + Dt)
            .Value = Ray(n, 1)
            .Interior.ColorIndex = Ray(n, 2)
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
        [COLOR="Navy"]End[/COLOR] With
    [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 22, 2017

MickG said:

Hello Moti,
Thank you for your good wishes.

Try this modified code:-

Code:

[COLOR=navy]Sub[/COLOR] MG22Nov42
[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] Dt [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 3)
[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
        [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
       Ray(R(1).Column - 2, 3) = Dt
    [COLOR=navy]Next[/COLOR] R
[COLOR=navy]Next[/COLOR] K
.RemoveAll
c = 0
[COLOR=navy]Select[/COLOR] [COLOR=navy]Case[/COLOR] Dn.Value
    [COLOR=navy]Case[/COLOR] "X": Dt = 1
    [COLOR=navy]Case[/COLOR] 1: Dt = 0
    [COLOR=navy]Case[/COLOR] 2: Dt = 2
[COLOR=navy]End[/COLOR] Select
[COLOR=navy]For[/COLOR] n = 1 To 14
    [COLOR=navy]If[/COLOR] Not IsEmpty(Ray(n, 1)) [COLOR=navy]Then[/COLOR]
        c = c + 1
        [COLOR=navy]With[/COLOR] Dn.Offset(, 14 + c + Dt)
            .Value = Ray(n, 1)
            .Interior.ColorIndex = Ray(n, 2)
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
        [COLOR=navy]End[/COLOR] With
    [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, really this change helped a lot to me it is just perfect!

Many thanks and Good Luck to you

Regards,
Moti

MickG · Nov 22, 2017

You're very welcome

Require modification in the current VBA

motilulla

Well-known Member

Excel Facts

MickG

MrExcel MVP

motilulla

Well-known Member

MickG

MrExcel MVP

Similar threads

Forum statistics

Share this page

Require modification in the current VBA

motilulla

Well-known Member

Excel Facts

MickG

MrExcel MVP

motilulla

Well-known Member

MickG

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