Simplification of Repetative Actions on 2 sets of Different Ranges

[vanhunk]

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]

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:
Screenshot 2023-06-02 142247.jpg

I had E2:E21 full of {1,2,3,1,2,3,1,2,3,1,2,3 etc...}

[vanhunk]

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]

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]

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]

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]

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:
Screenshot 2023-06-02 142247.jpg

I had E2:E21 full of {1,2,3,1,2,3,1,2,3,1,2,3 etc...}

[vanhunk]

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]

"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]

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]

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]

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