excelvbarangeselect-case

Using the select-case statement with cells within ranges


My idea is to fill the cells on column H depending on what the corresponding cell in the range A:A,D:D,F:F contains.

I'm getting the run-time error 13 (type mismatch) on the line Case "Done", though I'm not sure why, as both the selected range and the variable input are strings. I've always used if-loops, this is the first time I'm using select case, but despite having read the reference I still don't know what am I doing wrong.

The second question is how to define the last filled row of a range as the end of a new range. Right now with newRange.Value I'm attributing a value to the entire column, but I'm trying to make sure it only applies to the corresponding cell.

(For clarification, if for example cell A3 contains a value, that means D3 and F3 are empty, so each row in the range A:A,D:D,F:F only contains one value.)

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

Solution

  • Application.Match Applied on Array Instead of 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