Log in

View Full Version : [SLEEPER:] Simplification of Repetative Actions on 2 sets of Different Ranges


vanhunk
06-02-2023, 05:45 AM
Can the code below be simplified?

The same actions are done on 20 sets of 2 ranges each. It would have been great to be able to use a "With" within a "With", but the program will not know which "With" the code is referring to. I also tried arrays but got nowhere.
I believe it is quite challenging for most, excluding the gurus, and also poses a great learning opportunity for the subscribers.

All assistance is greatly appreciated



Sub ToetsAntwoorde()
Dim Colour1 As Long
Dim Colour3 As Variant
Dim Colour2 As Variant
Colour1 = RGB(0, 255, 0)
Colour2 = RGB(255, 255, 255)
Colour3 = RGB(255, 0, 0)
With Sheets("Antwoorde")
If .Range("E2") = 1 Then Application.Sheets("Blokraai 1").Range("$R$2:$R$8").Interior.Color = Colour1 Else
If .Range("E2") = 2 Then Application.Sheets("Blokraai 1").Range("$R$2:$R$8").Interior.Color = Colour2 Else
If .Range("E2") = 3 Then Application.Sheets("Blokraai 1").Range("$R$2:$R$8").Interior.Color = Colour3
If .Range("E3") = 1 Then Application.Sheets("Blokraai 1").Range("$V$3:$V$7").Interior.Color = Colour1 Else
If .Range("E3") = 2 Then Application.Sheets("Blokraai 1").Range("$V$3:$V$7").Interior.Color = Colour2 Else
If .Range("E3") = 3 Then Application.Sheets("Blokraai 1").Range("$V$3:$V$7").Interior.Color = Colour3
If .Range("E4") = 1 Then Application.Sheets("Blokraai 1").Range("$I$5:$O$5").Interior.Color = Colour1 Else
If .Range("E4") = 2 Then Application.Sheets("Blokraai 1").Range("$I$5:$O$5").Interior.Color = Colour2 Else
If .Range("E4") = 3 Then Application.Sheets("Blokraai 1").Range("$I$5:$O$5").Interior.Color = Colour3
If .Range("E5") = 1 Then Application.Sheets("Blokraai 1").Range("$N$5:$N$13").Interior.Color = Colour1 Else
If .Range("E5") = 2 Then Application.Sheets("Blokraai 1").Range("$N$5:$N$13").Interior.Color = Colour2 Else
If .Range("E5") = 3 Then Application.Sheets("Blokraai 1").Range("$N$5:$N$13").Interior.Color = Colour3
If .Range("E6") = 1 Then Application.Sheets("Blokraai 1").Range("$P$6:$V$6").Interior.Color = Colour1 Else
If .Range("E6") = 2 Then Application.Sheets("Blokraai 1").Range("$P$6:$V$6").Interior.Color = Colour2 Else
If .Range("E6") = 3 Then Application.Sheets("Blokraai 1").Range("$P$6:$V$6").Interior.Color = Colour3
If .Range("E7") = 1 Then Application.Sheets("Blokraai 1").Range("$T$6:$T$13").Interior.Color = Colour1 Else
If .Range("E7") = 2 Then Application.Sheets("Blokraai 1").Range("$T$6:$T$13").Interior.Color = Colour2 Else
If .Range("E7") = 3 Then Application.Sheets("Blokraai 1").Range("$T$6:$T$13").Interior.Color = Colour3
If .Range("E8") = 1 Then Application.Sheets("Blokraai 1").Range("$F$7:$J$7").Interior.Color = Colour1 Else
If .Range("E8") = 2 Then Application.Sheets("Blokraai 1").Range("$F$7:$J$7").Interior.Color = Colour2 Else
If .Range("E8") = 3 Then Application.Sheets("Blokraai 1").Range("$F$7:$J$7").Interior.Color = Colour3
If .Range("E9") = 1 Then Application.Sheets("Blokraai 1").Range("$J$7:$J$14").Interior.Color = Colour1 Else
If .Range("E9") = 2 Then Application.Sheets("Blokraai 1").Range("$J$7:$J$14").Interior.Color = Colour2 Else
If .Range("E9") = 3 Then Application.Sheets("Blokraai 1").Range("$J$7:$J$14").Interior.Color = Colour3
If .Range("E10") = 1 Then Application.Sheets("Blokraai 1").Range("$P$9:$P$16").Interior.Color = Colour1 Else
If .Range("E10") = 2 Then Application.Sheets("Blokraai 1").Range("$P$9:$P$16").Interior.Color = Colour2 Else
If .Range("E10") = 3 Then Application.Sheets("Blokraai 1").Range("$P$9:$P$16").Interior.Color = Colour3
If .Range("E11") = 1 Then Application.Sheets("Blokraai 1").Range("$D$11:$J$11").Interior.Color = Colour1 Else
If .Range("E11") = 2 Then Application.Sheets("Blokraai 1").Range("$D$11:$J$11").Interior.Color = Colour2 Else
If .Range("E11") = 3 Then Application.Sheets("Blokraai 1").Range("$D$11:$J$11").Interior.Color = Colour3
If .Range("E12") = 1 Then Application.Sheets("Blokraai 1").Range("$L$11:$L$20").Interior.Color = Colour1 Else
If .Range("E12") = 2 Then Application.Sheets("Blokraai 1").Range("$L$11:$L$20").Interior.Color = Colour2 Else
If .Range("E12") = 3 Then Application.Sheets("Blokraai 1").Range("$L$11:$L$20").Interior.Color = Colour3
If .Range("E13") = 1 Then Application.Sheets("Blokraai 1").Range("$R$11:$R$17").Interior.Color = Colour1 Else
If .Range("E13") = 2 Then Application.Sheets("Blokraai 1").Range("$R$11:$R$17").Interior.Color = Colour2 Else
If .Range("E13") = 3 Then Application.Sheets("Blokraai 1").Range("$R$11:$R$17").Interior.Color = Colour3
If .Range("E14") = 1 Then Application.Sheets("Blokraai 1").Range("$J$13:$U$13").Interior.Color = Colour1 Else
If .Range("E14") = 2 Then Application.Sheets("Blokraai 1").Range("$J$13:$U$13").Interior.Color = Colour2 Else
If .Range("E14") = 3 Then Application.Sheets("Blokraai 1").Range("$J$13:$U$13").Interior.Color = Colour3
If .Range("E15") = 1 Then Application.Sheets("Blokraai 1").Range("$V$14:$V$19").Interior.Color = Colour1 Else
If .Range("E15") = 2 Then Application.Sheets("Blokraai 1").Range("$V$14:$V$19").Interior.Color = Colour2 Else
If .Range("E15") = 3 Then Application.Sheets("Blokraai 1").Range("$V$14:$V$19").Interior.Color = Colour3
If .Range("E16") = 1 Then Application.Sheets("Blokraai 1").Range("$E$15:$E$22").Interior.Color = Colour1 Else
If .Range("E16") = 2 Then Application.Sheets("Blokraai 1").Range("$E$15:$E$22").Interior.Color = Colour2 Else
If .Range("E16") = 3 Then Application.Sheets("Blokraai 1").Range("$E$15:$E$22").Interior.Color = Colour3
If .Range("E17") = 1 Then Application.Sheets("Blokraai 1").Range("$R$15:$W$15").Interior.Color = Colour1 Else
If .Range("E17") = 2 Then Application.Sheets("Blokraai 1").Range("$R$15:$W$15").Interior.Color = Colour2 Else
If .Range("E17") = 3 Then Application.Sheets("Blokraai 1").Range("$R$15:$W$15").Interior.Color = Colour3
If .Range("E18") = 1 Then Application.Sheets("Blokraai 1").Range("$B$16:$I$16").Interior.Color = Colour1 Else
If .Range("E18") = 2 Then Application.Sheets("Blokraai 1").Range("$B$16:$I$16").Interior.Color = Colour2 Else
If .Range("E18") = 3 Then Application.Sheets("Blokraai 1").Range("$B$16:$I$16").Interior.Color = Colour3
If .Range("E19") = 1 Then Application.Sheets("Blokraai 1").Range("$R$17:$T$17").Interior.Color = Colour1 Else
If .Range("E19") = 2 Then Application.Sheets("Blokraai 1").Range("$R$17:$T$17").Interior.Color = Colour2 Else
If .Range("E19") = 3 Then Application.Sheets("Blokraai 1").Range("$R$17:$T$17").Interior.Color = Colour3
If .Range("E20") = 1 Then Application.Sheets("Blokraai 1").Range("$D$19:$L$19").Interior.Color = Colour1 Else
If .Range("E20") = 2 Then Application.Sheets("Blokraai 1").Range("$D$19:$L$19").Interior.Color = Colour2 Else
If .Range("E20") = 3 Then Application.Sheets("Blokraai 1").Range("$D$19:$L$19").Interior.Color = Colour3
If .Range("E21") = 1 Then Application.Sheets("Blokraai 1").Range("$B$22:$G$22").Interior.Color = Colour1 Else
If .Range("E21") = 2 Then Application.Sheets("Blokraai 1").Range("$B$22:$G$22").Interior.Color = Colour2 Else
If .Range("E21") = 3 Then Application.Sheets("Blokraai 1").Range("$B$22:$G$22").Interior.Color = Colour3
End With
End Sub

Best Regards
Vanhunks
georgiboy
06-02-2023, 06:21 AM
The below is a bit shorter, not sure how it will work in your situation:

Sub ToetsAntwoorde()
Dim rCell As Range, ColArr As Variant, rngArr As Variant, x As Long
ColArr = Array(RGB(0, 255, 0), RGB(255, 255, 255), RGB(255, 0, 0))
rngArr = Array("R2:R8", "V3:V7", "I5:O5", "N5:N13", "P6:V6", "T6:T13", "F7:J7", "J7:J14", "P9:P16", "D11:J11", "L11:L20", _
"R11:R17", "J13:U13", "V14:V19", "E15:E22", "R15:W15", "B16:I16", "R17:T17", "D19:L19", "B22:G22")
For Each rCell In Sheets("Antwoorde").Range("E2:E21").Cells
With Application.Sheets("Blokraai 1").Range(rngArr(x)).Interior
If rCell = 1 Then .Color = ColArr(rCell - 1) Else If rCell = 2 Then .Color = ColArr(rCell - 1) Else If rCell = 3 Then .Color = ColArr(rCell - 1)
End With
x = x + 1
Next rCell
End Sub

Creates a pretty image:
30842

I had E2:E21 full of {1,2,3,1,2,3,1,2,3,1,2,3 etc...}
vanhunk
06-02-2023, 07:09 AM
Hi Georgiboy

I love what you've done. Not sure if it will work yet.

I attach the example file for better clarity.

Best Regards
Vanhunk
Paul_Hossler
06-02-2023, 11:49 AM
Another way

Didn't really test it



Option Explicit
Dim Colour1 As Long
Dim Colour2 As Long
Dim Colour3 As Long

'Remove the interior colours of the crossword puzzle
Sub HerstelBlokKleure()
Dim r As Range
Application.ScreenUpdating = False
Colour1 = RGB(0, 255, 0)
Colour2 = RGB(255, 255, 255)
Colour3 = RGB(255, 0, 0)
For Each r In Worksheets("Blokraai 1").Range("A1:W22").Cells
With r
If .Interior.Color = Colour1 Or .Interior.Color = Colour2 Or .Interior.Color = Colour3 Then .Interior.ColorIndex = xlColorIndexNone
End With
Next
Application.Goto Range("A1")
Application.ScreenUpdating = True
End Sub

'Check the answers and colour blocks accordingly
Sub ToetsAntwoorde()
Dim ws As Worksheet
Dim r As Range
Set ws = Worksheets("Blokraai 1")
Colour1 = RGB(0, 255, 0)
Colour2 = RGB(255, 255, 255)
Colour3 = RGB(255, 0, 0)
With Sheets("Antwoorde")
Call AddColors(.Range("E3"), ws.Range("$V$3:$V$7"))
Call AddColors(.Range("E4"), ws.Range("$I$5:$O$5"))
Call AddColors(.Range("E5"), ws.Range("$N$5:$N$13"))
Call AddColors(.Range("E6"), ws.Range("$P$6:$V$6"))
Call AddColors(.Range("E7"), ws.Range("$T$6:$T$13"))
Call AddColors(.Range("E8"), ws.Range("$F$7:$J$7"))
Call AddColors(.Range("E9"), ws.Range("$J$7:$J$14"))
Call AddColors(.Range("E10"), ws.Range("$P$9:$P$16"))
Call AddColors(.Range("E11"), ws.Range("$D$11:$J$11"))
Call AddColors(.Range("E12"), ws.Range("$L$11:$L$20"))
Call AddColors(.Range("E13"), ws.Range("$R$11:$R$17"))
Call AddColors(.Range("E14"), ws.Range("$J$13:$U$13"))
Call AddColors(.Range("E15"), ws.Range("$V$14:$V$19"))
Call AddColors(.Range("E16"), ws.Range("$E$15:$E$22"))
Call AddColors(.Range("E17"), ws.Range("$R$15:$W$15"))
Call AddColors(.Range("E18"), ws.Range("$B$16:$I$16"))
Call AddColors(.Range("E19"), ws.Range("$R$17:$T$17"))
Call AddColors(.Range("E20"), ws.Range("$D$19:$L$19"))
Call AddColors(.Range("E21"), ws.Range("$B$22:$G$22"))
End With
End Sub

Sub VeeAntwoordeUit()
'Remove answers; reset blocword puzzle
Dim r As Range
Application.ScreenUpdating = False
Colour1 = RGB(0, 255, 0)
Colour2 = RGB(255, 255, 255)
Colour3 = RGB(255, 0, 0)
For Each r In Worksheets("Blokraai 1").Range("A1:W22").Cells
With r
If .Interior.Color = Colour1 Or .Interior.Color = Colour2 Or .Interior.Color = Colour3 Then
.Interior.ColorIndex = xlColorIndexNone
.ClearContents
End If
End With
Next
Application.Goto Range("A1")
Application.ScreenUpdating = True
End Sub

Private Sub AddColors(r As Range, r2 As Range)
Select Case r.Value
Case 1
r2.Interior.Color = Colour1
Case 2
r2.Interior.Color = Colour2
Case 3
r2.Interior.Color = Colour3
End Select
End Sub
p45cal
06-02-2023, 01:59 PM
Another:

Sub ff()
ColArr = Array(RGB(0, 255, 0), RGB(255, 255, 255), RGB(255, 0, 0))
cc = Sheets("Antwoorde").Range("E2:E21").Value
On Error Resume Next
For i = 1 To UBound(cc)
Sheets("Blokraai 1").Range("R2:R8, V3:V7, I5:O5, N5:N13, P6:V6, T6:T13, F7:J7, J7:J14, P9:P16, D11:J11, L11:L20, R11:R17, J13:U13, _
V14:V19, E15:E22, R15:W15, B16:I16, R17:T17, D19:L19, B22:G22").Areas(i).Interior.Color = ColArr(cc(i, 1) - 1)
Next i
End Sub
vanhunk
06-05-2023, 07:05 AM
Hi p45cal

I am not exactly sure how it works, but it works fantastic and it is really compact. Thank you so much, your time and effort is much appreciated.

Best Regards
Vanhunk

Another:
Sub ff()
ColArr = Array(RGB(0, 255, 0), RGB(255, 255, 255), RGB(255, 0, 0))
cc = Sheets("Antwoorde").Range("E2:E21").Value
On Error Resume Next
For i = 1 To UBound(cc)
Sheets("Blokraai 1").Range("R2:R8, V3:V7, I5:O5, N5:N13, P6:V6, T6:T13, F7:J7, J7:J14, P9:P16, D11:J11, L11:L20, R11:R17, J13:U13, _
V14:V19, E15:E22, R15:W15, B16:I16, R17:T17, D19:L19, B22:G22").Areas(i).Interior.Color = ColArr(cc(i, 1) - 1)
Next i
End Sub
vanhunk
06-05-2023, 07:10 AM
Hi georgiboy

Unfortunately your code didn't work for this application. Your time and effort is much appreciated.


The below is a bit shorter, not sure how it will work in your situation:

Sub ToetsAntwoorde()
Dim rCell As Range, ColArr As Variant, rngArr As Variant, x As Long
ColArr = Array(RGB(0, 255, 0), RGB(255, 255, 255), RGB(255, 0, 0))
rngArr = Array("R2:R8", "V3:V7", "I5:O5", "N5:N13", "P6:V6", "T6:T13", "F7:J7", "J7:J14", "P9:P16", "D11:J11", "L11:L20", _
"R11:R17", "J13:U13", "V14:V19", "E15:E22", "R15:W15", "B16:I16", "R17:T17", "D19:L19", "B22:G22")
For Each rCell In Sheets("Antwoorde").Range("E2:E21").Cells
With Application.Sheets("Blokraai 1").Range(rngArr(x)).Interior
If rCell = 1 Then .Color = ColArr(rCell - 1) Else If rCell = 2 Then .Color = ColArr(rCell - 1) Else If rCell = 3 Then .Color = ColArr(rCell - 1)
End With
x = x + 1
Next rCell
End Sub

Creates a pretty image:
30842

I had E2:E21 full of {1,2,3,1,2,3,1,2,3,1,2,3 etc...}
vanhunk
06-05-2023, 07:22 AM
Hi Paul
I did a quick test and it didn't work, not sure why though. Thank you very much for your time and effort.

Regards
Vanhunk
Paul_Hossler
06-05-2023, 07:47 PM
"didn't work" is not very explainatory

It seems to work based on what I was expecting it to do based on your logic

My version seems to get the same results as your version with the longer code
georgiboy
06-05-2023, 10:20 PM
While I can apreciate that you have thanked me for my time, could you spare me some of yours to explain: "Unfortunately your code didn't work for this application"
p45cal
06-06-2023, 02:32 AM
Sometimes, in some cells, a red would overlay a green implying that that letter was wrong so I tweaked my offering to apply the colours in order:

Sub ff()
ColArr = Array(RGB(255, 255, 255), RGB(255, 0, 0), RGB(0, 255, 0)) 'changed order
cc = Sheets("Antwoorde").Range("E2:E21").Value
With Sheets("Blokraai 1")
.Range("R2:R8, V3:V7, I5:O5, N5:N13, P6:V6, T6:T13, F7:J7, J7:J14, P9:P16, D11:J11, L11:L20, R11:R17, J13:U13, V14:V19, _
E15:E22, R15:W15, B16:I16, R17:T17, D19:L19, B22:G22")
On Error Resume Next
For v = 1 To 3 'loop through each colour, white first then red, finally green
For i = 1 To UBound(cc)
If v = cc(i, 1) Then .Areas(i).Interior.Color = ColArr(cc(i, 1) - 1)
Next i
Next v
End With
End Sub
georgiboy
06-06-2023, 04:03 AM
As I found this task interesting I ended up creating a version that will work in Excel 365:

Sub ToetsAntwoorde()
Dim var As Variant, x As Long, ColArr As Variant
var = Evaluate("SORT(Antwoorde!E2:F21,2,1)")
ColArr = Array(vbWhite, vbRed, vbGreen)
For x = 1 To UBound(var)
Range(var(x, 1)).Interior.Color = ColArr(var(x, 2) - 1)
Next x
End Sub

I think this as simple as I could make it
vanhunk
07-31-2024, 06:41 AM
"didn't work" is not very explainatory

It seems to work based on what I was expecting it to do based on your logic

My version seems to get the same results as your version with the longer code

Hi Paul
My apologies for only coming back to you know. I have been out of it for a long time.

When I tested it, I got, for instance, the following:
31738

Instead of:
31739
vanhunk
07-31-2024, 07:18 AM
Another:
Sub ff()
ColArr = Array(RGB(0, 255, 0), RGB(255, 255, 255), RGB(255, 0, 0))
cc = Sheets("Antwoorde").Range("E2:E21").Value
On Error Resume Next
For i = 1 To UBound(cc)
Sheets("Blokraai 1").Range("R2:R8, V3:V7, I5:O5, N5:N13, P6:V6, T6:T13, F7:J7, J7:J14, P9:P16, D11:J11, L11:L20, R11:R17, J13:U13, _
V14:V19, E15:E22, R15:W15, B16:I16, R17:T17, D19:L19, B22:G22").Areas(i).Interior.Color = ColArr(cc(i, 1) - 1)
Next i
End Sub


Hi p45cal
How would you declare ColArr, i.e., DIM(???)

Regards
vanhunk
vanhunk
07-31-2024, 07:27 AM
Sometimes, in some cells, a red would overlay a green implying that that letter was wrong so I tweaked my offering to apply the colours in order:

Sub ff()
ColArr = Array(RGB(255, 255, 255), RGB(255, 0, 0), RGB(0, 255, 0)) 'changed order
cc = Sheets("Antwoorde").Range("E2:E21").Value
With Sheets("Blokraai 1")
.Range("R2:R8, V3:V7, I5:O5, N5:N13, P6:V6, T6:T13, F7:J7, J7:J14, P9:P16, D11:J11, L11:L20, R11:R17, J13:U13, V14:V19, _
E15:E22, R15:W15, B16:I16, R17:T17, D19:L19, B22:G22")
On Error Resume Next
For v = 1 To 3 'loop through each colour, white first then red, finally green
For i = 1 To UBound(cc)
If v = cc(i, 1) Then .Areas(i).Interior.Color = ColArr(cc(i, 1) - 1)
Next i
Next v
End With
End Sub


Hi p45cal

The second version does not work so well. See test below:
31740

Regards
vanhunk