对范围内的单元格使用 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