UDF To Concatenate

[fredlo2010]

Hello,

I have created a function to concatenate the values provided by the user via a range. The function is working properly and I have timed it and it takes no noticeable time to calculate at all. But for some reason the it looks bulky and heavy; I am using quite a few variables to make sure all my data is checked.

The users can only pick two equal range, they must be one column or row of width (or height) and it cannot contain one cell.



Option Explicit


Function CreateString(rParams As Range, rValues As Range) As String


Dim arrParams As Variant
Dim arrValues As Variant
Dim lRowParams As Long
Dim lColParams As Long
Dim lRowValues As Long
Dim lColValues As Long
Dim ret As String
Dim i As Long

lRowParams = rParams.Rows.Count
lColParams = rParams.Columns.Count
lRowValues = rParams.Rows.Count
lColValues = rValues.Columns.Count

Application.Volatile True

' Check if the user picked the whole column
If Not lRowParams = Rows.Count And Not lRowValues = Rows.Count And _
Not lColParams = Columns.Count And Not lColValues = Columns.Count Then

' Check if the ranges are one cell.
If Not (lRowParams * lColParams) = 1 And Not (lRowValues * lColValues) = 1 Then

' Make sure the ranges are the same size
If lRowParams = lRowValues And lColParams = lColValues Then

' Check that its exactly one column or one row.
If lRowParams = 1 Or lColParams = 1 Then

' Load the array
arrParams = rParams.Value
arrValues = rValues.Value

' Transpose the array as needed to make sure there is only one
' dimension.
If Not lRowParams = 1 Then
arrParams = Application.Transpose(arrParams)
arrValues = Application.Transpose(arrValues)
Else
arrParams = Application.Transpose(Application.Transpose(arrParams))
arrValues = Application.Transpose(Application.Transpose(arrValues))
End If

' Add the string
For i = LBound(arrParams) To UBound(arrParams)
ret = ret & " " & arrParams(i) & " " & arrValues(i)
Next i
End If
End If
End If
End If

' Return the value
CreateString = ret


End Function


What do you think? Thanks :)

[mancubus]

hi.

check lRowValues = rParams.Rows.Count first please. :)

that said, if it were my assignment, i would code it like this.



Function CreateString(rParams As Range, rValues As Range) As String

Dim arrParams As Variant
Dim arrValues As Variant
Dim ret As String
Dim i As Long

'Check if the user picked the whole column
If rParams.Rows.Count = Rows.Count Or _
rParams.Columns.Count = Columns.Count Or _
rValues.Rows.Count = Rows.Count Or _
rValues.Columns.Count = Columns.Count Then
MsgBox "You can not pick whole row or column!"
CreateString = "Error!"
Exit Function
End If

'Check if the ranges are one cell.
If rParams.Count = 1 Or rValues.Count = 1 Then
MsgBox "You can not pick one cell!"
CreateString = "Error!"
Exit Function
End If

'Make sure the ranges are the same size
If rParams.Rows.Count <> rValues.Rows.Count And _
rParams.Columns.Count <> rValues.Columns.Count Then
MsgBox "The two ranges' sizes must be equal!"
CreateString = "Error!"
Exit Function
End If

'Load the array
arrParams = rParams.Value
arrValues = rValues.Value

'Transpose the array as needed to make sure there is only one dimension.
If rParams.Columns.Count = 1 Then
arrParams = Application.Transpose(arrParams)
arrValues = Application.Transpose(arrValues)
Else
arrParams = Application.Transpose(Application.Transpose(arrParams))
arrValues = Application.Transpose(Application.Transpose(arrValues))
End If

'Check that its exactly one column or one row.
If UBound(arrParams) <> UBound(arrValues) Then
MsgBox "The two ranges' sizes must be equal!"
CreateString = "Error!"
Exit Function
End If

'Add the string
For i = LBound(arrParams) To UBound(arrParams)
ret = ret & " " & arrParams(i) & " " & arrValues(i)
Next i

'Return the value
CreateString = Mid(ret, 2)

End Function


for volatility pls see:
http://www.decisionmodels.com/calcsecretsj.htm

[fredlo2010]

Hi mancubus,

Thanks a lot for the reply. I already noticed the problem here:


check lRowValues = rParams.Rows.Count

[mancubus]

you are welcome.
below is 'corrected' code for one column / one row test.



Function CreateString(rParams As Range, rValues As Range) As String

Dim arrParams As Variant
Dim arrValues As Variant
Dim ret As String
Dim i As Long

'Check if the user picked the whole column
If rParams.Rows.Count = Rows.Count Or _
rParams.Columns.Count = Columns.Count Or _
rValues.Rows.Count = Rows.Count Or _
rValues.Columns.Count = Columns.Count Then
MsgBox "You can not pick whole row or column!"
CreateString = "Error!"
Exit Function
End If

'Check if the ranges are one cell.
If rParams.Count = 1 Or rValues.Count = 1 Then
MsgBox "You can not pick one cell!"
CreateString = "Error!"
Exit Function
End If

'Make sure the ranges are the same size
If rParams.Rows.Count <> rValues.Rows.Count And _
rParams.Columns.Count <> rValues.Columns.Count Then
MsgBox "The two ranges' sizes must be equal!"
CreateString = "Error!"
Exit Function
End If

'Check that its exactly one column or one row. Because of previous tests, test for 1 range is sufficient.
If rParams.Rows.Count > 1 Then
If rParams.Columns.Count > 1 Then
MsgBox "The ranges must be in one row or in one column!"
CreateString = "Error!"
Exit Function
End If
End If
If rParams.Columns.Count > 1 Then
If rParams.Rows.Count > 1 Then
MsgBox "The ranges must be in one row or in one column!"
CreateString = "Error!"
Exit Function
End If
End If

'Load the array
arrParams = rParams.Value
arrValues = rValues.Value
'Transpose the array as needed to make sure there is only one dimension.
If rParams.Columns.Count = 1 Then
arrParams = Application.Transpose(arrParams)
arrValues = Application.Transpose(arrValues)
Else
arrParams = Application.Transpose(Application.Transpose(arrParams))
arrValues = Application.Transpose(Application.Transpose(arrValues))
End If

'Add the string
For i = LBound(arrParams) To UBound(arrParams)
ret = ret & " " & arrParams(i) & " " & arrValues(i)
Next i

'Return the value
CreateString = Mid(ret, 2)

End Function


if you are going to handle all possible errors the users can make, your code will be longer.

imo, we don't have to worry about the length of the code as long as they serve our ultimate purpose .

[fredlo2010]

if you are going to handle all possible errors the users can make, your code will be longer.

Thanks mancubus for all your help.

I have added a few things to my code that I need to check to make sure the final string is formatted the way I want. Also I don't really care about the error since this function will be used by a handful of people that will be trained on how it works.



Function CreateString(rParams As Range, rValues As Range) As String


Const strERROR_MESSAGE As String = "Error, ranges have to be: Same size, No full rows/columns, No single cell"

Dim arrParams As Variant
Dim arrValues As Variant
Dim lRowParams As Long
Dim lColParams As Long
Dim lRowValues As Long
Dim lColValues As Long
Dim ret As String
Dim i As Long

lRowParams = rParams.Rows.Count
lColParams = rParams.Columns.Count
lRowValues = rValues.Rows.Count
lColValues = rValues.Columns.Count


' Check if the user picked the whole column
If Not lRowParams = Rows.Count And Not lRowValues = Rows.Count And _
Not lColParams = Columns.Count And Not lColValues = Columns.Count Then


' Check if the ranges are one cell.
If Not (lRowParams = lColParams) = 1 And Not (lRowValues = lColValues) = 1 Then


' Make sure the ranges are the same size
If lRowParams = lRowValues And lColParams = lColValues Then


' Check that its exactly one column or one row.
If lRowParams = 1 Or lColParams = 1 Then


' Load the array
arrParams = rParams.Value
arrValues = rValues.Value


' Transpose the array as needed to make sure there is only one
' dimension.
If Not lRowParams = 1 Then
arrParams = Application.Transpose(arrParams)
arrValues = Application.Transpose(arrValues)
Else
arrParams = Application.Transpose(Application.Transpose(arrParams))
arrValues = Application.Transpose(Application.Transpose(arrValues))
End If

' Add the string.
For i = LBound(arrParams) To UBound(arrParams)
If Not arrParams(i) = Empty And Not ret = vbNullString Then
ret = ret & " " & Trim$(arrParams(i)) & " " & Trim$(arrValues(i))
ElseIf arrParams(i) = Empty And Not ret = vbNullString Then
ret = ret & " " & Trim$(arrValues(i))
ElseIf Not arrParams(i) = Empty And ret = vbNullString Then
ret = Trim$(arrParams(i)) & " " & Trim$(arrValues(i))
ElseIf arrParams(i) = Empty And ret = vbNullString Then
ret = Trim$(arrValues(i))
End If
Next i
End If
End If
End If
End If

' Remove all extra spaces.
Do While InStr(1, ret, " ")
ret = Replace$(ret, " ", " ")
Loop

' Return the value. Errors have been condensed in a single message.
If Not ret = vbNullString Then
CreateString = Join(Split(ret, " "), " ")
Else
CreateString = strERROR_MESSAGE
End If

End Function



I have been timing it and the formula usually runs in a sample of 100 cells containing it and an array of 26 elements in about 0.002s for the first time (when formula is created) and about 0.00018s for changes. The user does not even notice and they is no calculation lag; so I am pretty happy with the results :)

Thanks again for the help. :) :) :)

[Paul_Hossler]

Pretty sure that this doesn't catch every possible user error, and only works with column data (could be extended to rows easily). It returns a standard Excel error since I assume the UDF will be in a WS cell




Option Explicit

Function CreateString_1(rParams As Range, rValues As Range) As Variant
Dim arrParams As Variant, arrValues As Variant
Dim i As Long
Dim sReturn As String

'only works with columns for now
arrParams = Application.WorksheetFunction.Transpose(Intersect(rParams.Columns(1), rParams.Parent.UsedRange))
arrValues = Application.WorksheetFunction.Transpose(Intersect(rValues.Columns(1), rValues.Parent.UsedRange))

'Check: two single cells
If Not IsArray(arrParams) And Not IsArray(arrValues) Then
CreateString_1 = arrParams & " " & arrValues
Exit Function
End If

'Check: only one is an array
If Not IsArray(arrParams) Or Not IsArray(arrValues) Then
CreateString_1 = CVErr(xlErrNA)
Exit Function
End If

'Check: same num elements in both arrays
If (UBound(arrParams) - LBound(arrParams)) <> (UBound(arrValues) - LBound(arrValues)) Then
CreateString_1 = CVErr(xlErrNA)
Exit Function
End If

'build return
For i = LBound(arrParams) To UBound(arrParams)
sReturn = sReturn & " " & arrParams(i) & " " & arrValues(i)
Next I

CreateString_1 = sReturn
End Function

[fredlo2010]

Thanks for the help Paul.

Yes the formula will be called from the worksheet.

[mancubus]

welcome.

everbody has his own taste and style. imo, informing the users about the errors they made is a good practice

[Paul_Hossler]

imo, informing the users about the errors they made is a good practice


Agreed, but since this UDF was intended to be used as a worksheet formula, I was thinking that a MsgBox because of an error conditions would be triggered every calculation, esp if the UDF was in a lot of cells

IMVHO using the Excel worksheet errors like #NA! etc. would be less intrusive

[mancubus]

Agreed too. :)

http://www.cpearson.com/excel/ReturningErrors.aspx made me think, in this specific case, msgboxes would guide on writing the correct formulas.