堆棧內存溢出
  簡體   English   中英

錯誤處理 Excel VBA

[英]Error Handling Excel VBA

 原文  2015-06-30 19:20:12  0   1    vba/ colors

問題描述

好的，

所以我今天一整天都在寫這個，我發現如果沒有檢測到顏色，它就會失敗。

大家覺得我應該怎么做？

我嘗試在處理整個事情時出錯，但沒有用。

代碼：

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

如果您有興趣，這里是為 B 列中具有特定值的所有行着色的代碼，上面的代碼依賴於此代碼。 但是如果列都是空白的怎么辦？ 我需要為這種情況做好計划。

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

1 個解決方案

解決方案1
 1 已采納  2015-06-30 23:31:12

這個：

'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

在功能上與此相同：

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

除非有其他事情你要遺漏。

並且由於您正在重復相同的塊，您可以將其包裝在一個 Sub 中並從您的主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

暫無
暫無

聲明:本站的技術帖子網頁，遵循CC BY-SA 4.0協議，如果您需要轉載，請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.

相關問題 Excel VBA錯誤處理 了解Excel VBA錯誤處理 Excel VBA中的嵌套錯誤處理 VBA Excel 簡單的錯誤處理 Excel VBA中的簡單錯誤處理 MS Excel VBA中的錯誤處理 VBA錯誤處理無法在Excel中工作 Excel VBA錯誤處理代碼 Excel VBA全局錯誤處理 VBA-錯誤時轉到goto excel錯誤消息
相關標簽
 
粵ICP備18138465號  © 2020-2024 STACKOOM.COM