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
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