PDA

View Full Version : 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