对范围内的单元格使用select-case语句

Question

我的想法是，根据A:A，D:D，F:F范围内相应的单元格，填充列H上的单元格。

我在行Case "Done"上得到了运行时错误13 (类型错配)，但我不知道为什么，因为所选的范围和变量输入都是字符串。我一直使用if-循环，这是我第一次使用select case，但是尽管阅读了引用，我仍然不知道我做错了什么。

的第二个问题是如何将区域的最后填充行定义为新范围的结束。现在，使用newRange.Value，我将一个值赋给整个列，但我试图确保它只适用于相应的单元格。

(为了澄清起见，如果单元格A3包含一个值，这意味着D3和F3为空，因此范围A:A、D:D、F:F中的每一行只包含一个值。)

Sub setStatus()

Dim dataRange As Range
Dim newRange As Range

Set dataRange = Range("A:A,D:D,F:F")
Set newRange = Range("H:H")

Select Case dataRange.Value

        Case "Done"
            newRange.Value = "Completed"
        Case "WIP"
            newRange.Value = "In Progress"
            'In reality there are many different cases, 
            'hence the select case instead of an if loop
        End Select
    Next

End Sub

Answer 1

Application.Match代替Select Case在阵列上的应用

Sub SetStatus()

    ' Constants
    Const SOURCE_FIRST_ROW As Long = 2
    Const DESTINATION_COLUMN As Long = 8
    ' Arrays
    Dim sCols() As Variant: sCols = VBA.Array(1, 4, 6) ' only one column has data
    Dim Cases() As Variant: Cases = VBA.Array( _
        "Done", "WIP")
    Dim Values() As Variant: Values = VBA.Array( _
        "Completed", "In Progress")
    
    ' Worksheet
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    ' Write the values from the source range to an array.
    
    Dim srg As Range: Set srg = ws.UsedRange
    Dim rOffset As Long: rOffset = SOURCE_FIRST_ROW - 1
    Dim rCount As Long: rCount = srg.Rows.Count - rOffset
    Set srg = srg.Resize(rCount).Offset(rOffset)
    Dim Data As Variant: Data = srg.Value
    
    Dim cUpper As Long: cUpper = UBound(sCols)
    
    ' Write the matching results to the 1st column of the array.
    
    Dim r As Long
    Dim c As Long
    Dim cString As String
    Dim cIndex As Variant
    Dim HasDataInRow As Boolean
    
    For r = 1 To rCount ' rows of the array
        For c = 0 To cUpper ' given columns of the array
            cString = CStr(Data(r, sCols(c)))
            If Len(cString) > 0 Then
                cIndex = Application.Match(cString, Cases, 0)
                If IsNumeric(cIndex) Then
                    Data(r, 1) = Values(cIndex - 1) ' found in Cases
                Else
                    Data(r, 1) = Empty ' not found in Cases
                End If
                HasDataInRow = True
                Exit For
                'Else ' is blank; do nothing
            End If
        Next c
        If HasDataInRow Then
            HasDataInRow = False
        Else
            Data(r, 1) = Empty ' the row was blank
        End If
    Next r
            
    ' Write the values from the first column of the array
    ' to the destination range.
            
    Dim drg As Range: Set drg = srg.Columns(DESTINATION_COLUMN)
            
    drg.Value = Data
      
    MsgBox "Status set.", vbInformation

End Sub