Okay,
So i was writing this all day today, and i just found out it fails if there are no colors detected.
What do you guys think i should do?
I tried a error handling the whole thing but it didnt work.
code:
Sub UpdateTemplate_off_Color()
Sheets("test code").Activate
'R-203
Text203 = Sheets("Original Data").Range("I24")
'R-18
Text18 = Sheets("Original Data").Range("I22")
'R-19
Text19 = Sheets("Original Data").Range("L26")
'R-21
Text21 = Sheets("Original Data").Range("I28")
'R-59
Text59 = Sheets("Original Data").Range("I30")
'R-650
Text650 = Sheets("Original Data").Range("I40")
'R-1161
Text1161 = Sheets("Original Data").Range("I38")
Dim rCell As Range
Dim lColor As Long
Dim rColored As Range
'code updated with a goto label if error, error only happens when color is not found
'fix code to not bug out if no colors found june30th 2:42pm
'R-203 - TEXT1
Color203 = RGB(153, 204, 255)
'R-18 - TEXT2
Color18 = RGB(204, 255, 255)
'R-19 - TEXT3
Color19 = RGB(192, 192, 192)
'R-21 - TEXT4
Color21 = RGB(255, 128, 128)
'R-59 - TEXT5
Color59 = RGB(204, 204, 255)
'R-650 - TEXT6
Color650 = RGB(255, 153, 0)
'R-1161 - TEXT7
Color1161 = RGB(255, 204, 0)
'R-203 - TEXT203
Range(Range("A2"), Range("A2").End(xlDown)).Select
Set rColored = Nothing
For Each rCell In Selection
If rCell.Interior.Color = Color203 Then
If rColored Is Nothing Then
Set rColored = rCell
Else
Set rColored = Union(rColored, rCell)
End If
End If
Next
On Error GoTo skipthispart203:
rColored.Select
Selection.Offset(0, 11).Select
For Each i In Selection
'i.Value = i.Value & Text
'i.Value = Text & i.Value
i.Value = Text203
Next i
skipthispart203:
Set rCell = Nothing
Set rColored = Nothing
'R-18 - TEXT18
Range(Range("A2"), Range("A2").End(xlDown)).Select
Set rColored = Nothing
For Each rCell In Selection
If rCell.Interior.Color = Color18 Then
If rColored Is Nothing Then
Set rColored = rCell
Else
Set rColored = Union(rColored, rCell)
End If
End If
Next
On Error GoTo skipthispart18:
rColored.Select
Selection.Offset(0, 11).Select
For Each i In Selection
'i.Value = i.Value & Text
'i.Value = Text & i.Value
i.Value = Text18
Next i
skipthispart18:
Set rCell = Nothing
Set rColored = Nothing
'R-19 - TEXT19
Range(Range("A2"), Range("A2").End(xlDown)).Select
Set rColored = Nothing
For Each rCell In Selection
If rCell.Interior.Color = Color19 Then
If rColored Is Nothing Then
Set rColored = rCell
Else
Set rColored = Union(rColored, rCell)
End If
End If
Next
On Error GoTo skipthispart19:
rColored.Select
Selection.Offset(0, 11).Select
For Each i In Selection
'i.Value = i.Value & Text
'i.Value = Text & i.Value
i.Value = Text19
Next i
skipthispart19:
Set rCell = Nothing
Set rColored = Nothing
'R-21 - TEXT21
Range(Range("A2"), Range("A2").End(xlDown)).Select
Set rColored = Nothing
For Each rCell In Selection
If rCell.Interior.Color = Color21 Then
If rColored Is Nothing Then
Set rColored = rCell
Else
Set rColored = Union(rColored, rCell)
End If
End If
Next
On Error GoTo skipthispart21:
rColored.Select
Selection.Offset(0, 11).Select
For Each i In Selection
'i.Value = i.Value & Text
'i.Value = Text & i.Value
i.Value = Text21
Next i
skipthispart21:
Set rCell = Nothing
Set rColored = Nothing
'R-59 - TEXT59
Range(Range("A2"), Range("A2").End(xlDown)).Select
Set rColored = Nothing
For Each rCell In Selection
If rCell.Interior.Color = Color59 Then
If rColored Is Nothing Then
Set rColored = rCell
Else
Set rColored = Union(rColored, rCell)
End If
End If
Next
On Error GoTo skipthispart59:
rColored.Select
Selection.Offset(0, 11).Select
For Each i In Selection
'i.Value = i.Value & Text
'i.Value = Text & i.Value
i.Value = Text59
Next i
skipthispart59:
Set rCell = Nothing
Set rColored = Nothing
'R-650 - TEXT650
Range(Range("A2"), Range("A2").End(xlDown)).Select
Set rColored = Nothing
For Each rCell In Selection
If rCell.Interior.Color = Color650 Then
If rColored Is Nothing Then
Set rColored = rCell
Else
Set rColored = Union(rColored, rCell)
End If
End If
Next
On Error GoTo skipthispart650:
rColored.Select
Selection.Offset(0, 11).Select
For Each i In Selection
'i.Value = i.Value & Text
'i.Value = Text & i.Value
i.Value = Text650
Next i
skipthispart650:
Set rCell = Nothing
Set rColored = Nothing
'R-1161 - TEXT1161
Range(Range("A2"), Range("A2").End(xlDown)).Select
Set rColored = Nothing
For Each rCell In Selection
If rCell.Interior.Color = Color1161 Then
If rColored Is Nothing Then
Set rColored = rCell
Else
Set rColored = Union(rColored, rCell)
End If
End If
Next
On Error GoTo skipthispart1161:
rColored.Select
Selection.Offset(0, 11).Select
For Each i In Selection
'i.Value = i.Value & Text
'i.Value = Text & i.Value
i.Value = Text1161
Next i
skipthispart1161:
Set rCell = Nothing
Set rColored = Nothing
End Sub
IF you are interested, here is the code to color all rows with specific value in Column B the above code relies on this code. But what if the column is all blank? i need to plan for that situation.
Public Sub changecolor()
Range(Range("B2"), Range("B2").End(xlDown)).Select
'remove past colors
ActiveSheet.Cells.Interior.ColorIndex = xlNone
Set MyPlage = Selection
For Each Cell In MyPlage
Select Case Cell.Value
Case Is = "R-203"
Cells(Cell.Row, "A").Interior.ColorIndex = 37
Cells(Cell.Row, "B").Interior.ColorIndex = 37
Case Is = "M-946"
Cells(Cell.Row, "A").Interior.ColorIndex = 45
Cells(Cell.Row, "B").Interior.ColorIndex = 45
Case Is = "R-1161"
Cells(Cell.Row, "A").Interior.ColorIndex = 44
Cells(Cell.Row, "B").Interior.ColorIndex = 44
Case Is = "r-650"
Cells(Cell.Row, "A").Interior.ColorIndex = 45
Cells(Cell.Row, "B").Interior.ColorIndex = 45
Case Is = "R-650"
Cells(Cell.Row, "A").Interior.ColorIndex = 45
Cells(Cell.Row, "B").Interior.ColorIndex = 45
Case Is = "R-59"
Cells(Cell.Row, "A").Interior.ColorIndex = 24
Cells(Cell.Row, "B").Interior.ColorIndex = 24
Case Is = "R-21"
Cells(Cell.Row, "A").Interior.ColorIndex = 22
Cells(Cell.Row, "B").Interior.ColorIndex = 22
Case Is = "R-19"
Cells(Cell.Row, "A").Interior.ColorIndex = 15
Cells(Cell.Row, "B").Interior.ColorIndex = 15
Case Is = "R-18"
Cells(Cell.Row, "A").Interior.ColorIndex = 20
Cells(Cell.Row, "B").Interior.ColorIndex = 20
Case Else
Cell.EntireRow.Interior.ColorIndex = xlNone
End Select
Next
End Sub
This:
'R-203 - TEXT203
Range(Range("A2"), Range("A2").End(xlDown)).Select
Set rColored = Nothing
For Each rCell In Selection
If rCell.Interior.Color = Color203 Then
If rColored Is Nothing Then
Set rColored = rCell
Else
Set rColored = Union(rColored, rCell)
End If
End If
Next
On Error GoTo skipthispart203:
rColored.Select
Selection.Offset(0, 11).Select
For Each i In Selection
'i.Value = i.Value & Text
'i.Value = Text & i.Value
i.Value = Text203
Next i
skipthispart203:
Set rCell = Nothing
Set rColored = Nothing
Is functionally the same as this:
Dim rngSrch as Range, c As Range
Set rngSrch = Range(Range("A2"), Range("A2").End(xlDown))
For each c In rngSrch.Cells
If c.Interior.Color = Color203 Then
c.offset(0,11).Value = Text203
End If
Next c
Unless there's something else you're leaving out.
And since you're repeating the same block you can wrap it in a Sub and call it from your main UpdateTemplate_off_Color Sub:
Sub UpdateTemplate_off_Color()
Dim shtOD As Worksheet, shtTC As Worksheet
Dim rngSrch As Range
Set shtTC = Sheets("test code")
Set shtOD = Sheets("Original Data")
Set rngSrch = shtTC.Range(shtTC.Range("A2"), _
shtTC.Range("A2").End(xlDown))
TextByColor rngSrch, RGB(153, 204, 255), shtOD.Range("I24").Value 'R-203
TextByColor rngSrch, RGB(204, 255, 255), shtOD.Range("I22").Value 'R-18
TextByColor rngSrch, RGB(192, 192, 192), shtOD.Range("L26").Value 'R-19
TextByColor rngSrch, RGB(255, 128, 128), shtOD.Range("I28").Value 'R-21
TextByColor rngSrch, RGB(204, 204, 255), shtOD.Range("I30").Value 'R-59
TextByColor rngSrch, RGB(255, 153, 0), shtOD.Range("I40").Value 'R-650
TextByColor rngSrch, RGB(255, 204, 0), shtOD.Range("I38").Value 'R-1161
End Sub
Sub TextByColor(rngSrch As Range, clr As Long, txt)
Dim c As Range
For Each c In rngSrch.Cells
If c.Interior.Color = clr Then
c.Offset(0, 11).Value = txt
End If
Next c
End Sub