错误处理 Excel VBA

Question

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

Answer 1

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