Need help code is not performing

[Kishan]

Using Excel 2000</SPAN></SPAN>

Hi,</SPAN></SPAN>

I want to colour C:P columns as per values are set in the column R:Z, the macro were written by MickG, I been able to modified it get it work to colour row 6 only, I am not able to set all range from R6:Z19. After I run code it get stuck and highlight the line below </SPAN></SPAN>

"With Cells(r1 + r, 3 + c).Resize(, Dn.Value)"</SPAN></SPAN>

Sub MG16Sep23()
Dim Rng As Range, Dn As Range, r As Long, r1 As Long, c As Long, num As Long, Col As Variant
Set Rng = Range(Range("R6"), Range("R" & Columns.Count).End(xlToRight))
Col = Array(10, 3)
r1 = 6
r = 0
c = 0
For Each Dn In Rng
    With Cells(r1 + r, 3 + c).Resize(, Dn.Value)
        .Interior.ColorIndex = Col(num)
        .Font.ColorIndex = 2
    End With
    c = c + Dn.Value
    If c = 14 Then c = 0 & r1 = r1 + 1
    num = num + 1
    num = IIf(num = 2, 0, num)
Next Dn

End Sub

Please need help to make it work or please rewrite new one </SPAN></SPAN>

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
1
2
3
4
5			C1	C2	C3	C4	C5	C6	C7	C8	C9	C10	C11	C12	C13	C14		v1	v2	v3	v4	v5	v6	v7	v8	v9
6			X	1	2	1	2	X	X	1	1	2	1	X	2	2		1	2	2	2	3	4
7			1	X	2	2	2	1	X	X	2	2	X	X	1	1		5	5	2	2
8			1	X	1	1	X	X	2	2	X	X	1	1	X	X		2	6	2	4
9			1	X	1	2	2	1	X	1	1	X	1	2	2	1		2	3	2	6	1
10			X	1	X	1	X	1	1	X	1	1	1	X	X	1		1	2	1	3	5	1
11			X	X	X	1	1	1	1	X	1	X	2	1	2	X		3	5	3	2	1
12			2	X	1	1	1	2	X	X	X	1	1	1	2	1		1	1	4	3	4	1
13			X	1	X	X	1	1	1	1	1	1	1	X	1	1		1	3	8	2
14			2	1	1	X	2	1	1	X	2	X	2	2	2	X		1	4	4	4	1
15			X	1	1	2	X	1	2	1	1	1	1	1	1	X		1	3	1	2	7
16			1	2	1	2	X	2	1	X	1	2	X	1	1	1		2	2	2	2	2	1	3
17			2	X	X	1	2	2	1	1	1	2	1	1	1	X		1	2	3	4	4
18			1	1	1	1	2	1	1	1	2	1	2	1	X	X		5	4	2	3
19			1	2	1	2	1	1	1	2	2	1	2	1	1	X		2	2	5	2	3
20
21
Sheet8

Thank you in advance</SPAN></SPAN>

Regards,</SPAN>
Kishan</SPAN></SPAN>

 

[StephenCrump]

Here's one way:

Dim Rng As Range
Dim lFirstRow As Long, lNoRows As Long, lMaxCols As Long, Col1 As Long, Col2 As Long
Dim col As Long, r As Long, c As Long

lFirstRow = 6
lMaxCols = 14
lNoRows = Range("R" & Rows.Count).End(xlUp).Row - lFirstRow + 1
Set Rng = Range("R" & lFirstRow).Resize(lNoRows, lMaxCols)

With Range("C" & lFirstRow).Resize(lNoRows, lMaxCols)
    .Font.ColorIndex = 2
    .Interior.ColorIndex = xlNone
    For r = 1 To lNoRows
        With .Rows(r)
            Col1 = 1
            col = 10
            For c = 1 To lMaxCols
                Col2 = Application.Min(lMaxCols + 1, Col1 + Rng(r, c).Value)
                If Col1 = Col2 Then Exit For 'Assume we have run out of values if we encounter 0 or blank
                .Cells(Col1).Resize(, Col2 - Col1).Interior.ColorIndex = col
                If Col2 = lMaxCols + 1 Then Exit For
                Col1 = Col2
                col = IIf(col = 10, 3, 10)
            Next c
        End With
    Next r
End With

 

[Kishan]

Here's one way:

Dim Rng As Range
Dim lFirstRow As Long, lNoRows As Long, lMaxCols As Long, Col1 As Long, Col2 As Long
Dim col As Long, r As Long, c As Long

lFirstRow = 6
lMaxCols = 14
lNoRows = Range("R" & Rows.Count).End(xlUp).Row - lFirstRow + 1
Set Rng = Range("R" & lFirstRow).Resize(lNoRows, lMaxCols)

With Range("C" & lFirstRow).Resize(lNoRows, lMaxCols)
    .Font.ColorIndex = 2
    .Interior.ColorIndex = xlNone
    For r = 1 To lNoRows
        With .Rows(r)
            Col1 = 1
            col = 10
            For c = 1 To lMaxCols
                Col2 = Application.Min(lMaxCols + 1, Col1 + Rng(r, c).Value)
                If Col1 = Col2 Then Exit For 'Assume we have run out of values if we encounter 0 or blank
                .Cells(Col1).Resize(, Col2 - Col1).Interior.ColorIndex = col
                If Col2 = lMaxCols + 1 Then Exit For
                Col1 = Col2
                col = IIf(col = 10, 3, 10)
            Next c
        End With
    Next r
End With

Amazing!! StephenCrump, thank you very much for rewriting the fully new macro, it is working like magic.</SPAN></SPAN>

I do appreciate your kind help and giving your precious time on it.</SPAN></SPAN>

Have a beautiful weekend</SPAN></SPAN>

Good Luck</SPAN></SPAN>

Kind Regards,</SPAN></SPAN>
Kishan </SPAN></SPAN>

 

[MickG]

Another option:-

[COLOR="Navy"]Sub[/COLOR] MG03Aug04
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] RngAc [COLOR="Navy"]As[/COLOR] Range, R [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("C6"), Range("C" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    Num = 0
    [COLOR="Navy"]Set[/COLOR] RngAc = Range(Dn.Offset(, 15), Cells(Dn.Row, Columns.Count).End(xlToLeft))
     [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] RngAc
          Dn.Offset(, Num).Resize(, R).Interior.Color = R.Interior.Color
         Num = Num + R
    [COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Kishan]

Another option:-

[COLOR=navy]Sub[/COLOR] MG03Aug04
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, Num [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] RngAc [COLOR=navy]As[/COLOR] Range, R [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Set[/COLOR] Rng = Range(Range("C6"), Range("C" & Rows.Count).End(xlUp))
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
    Num = 0
    [COLOR=navy]Set[/COLOR] RngAc = Range(Dn.Offset(, 15), Cells(Dn.Row, Columns.Count).End(xlToLeft))
     [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] R [COLOR=navy]In[/COLOR] RngAc
          Dn.Offset(, Num).Resize(, R).Interior.Color = R.Interior.Color
         Num = Num + R
    [COLOR=navy]Next[/COLOR] R
[COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

Wow!! Mick, very nice it fills the colours as per range R:Z columns colours, I liked the colouring trick.</SPAN></SPAN>

Added line to get font colour below the .Interior.Color</SPAN></SPAN>
Dn.Offset(, Num).Resize(, R).Font.Color = R.Font.Color

</SPAN></SPAN>

I do appreciate your kind help</SPAN></SPAN>

Have a beautiful weekend</SPAN></SPAN>

Good Luck</SPAN></SPAN>

Kind Regards,</SPAN></SPAN>
Kishan </SPAN></SPAN>