Function to summarize text in Vba Excel - excel

Question

Now I'm using MS Excel 2019. I desire to make function to get text at Summary Steps column and Sumary Values column from Steps and Values Column
It's described as .
I tried with this function. However, It doesn't work at all
Function Congdoan_Time(Congdoan As Range, Time As Range, gtri As Boolean) As String
Dim xValue, TimeValue As String
Dim xChar As String
Dim xOutValue, xTimeValue As String
xValue = Congdoan.Value
TimeValue = Time.Value
Dim arr, timearr As Variant
Dim text, texttime As String
Dim nextarr As Variant
arr = Split(xValue, ",")
timearr = Split(TimeValue, "-")
Dim i As Long
Dim vallue As Variant
vallue = timearr(0)
For i = LBound(arr) To UBound(arr) - 1
If arr(i) = arr(i + 1) And i < UBound(arr) - 1 Then
vallue = Val(vallue) + Val(timearr(i + 1))
End If
If arr(i) = arr(i + 1) And i = UBound(arr) - 1 Then
End If
If arr(i) <> arr(i + 1) Then
xOutValue = xOutValue & "," & arr(i)
xTimeValue = xTimeValue & "-" & vallue
vallue = Val(timearr(i + 1))
End If
Next i
If xOutValue = "" Then
xOutValue = Join(arr, ",")
xTimeValue = vallue
End If
text = Right(xOutValue, Len(xOutValue) - 1)
nextarr = Split(text, ",")
If arr(UBound(arr)) <> nextarr(UBound(nextarr)) Then
text = text & "," & arr(UBound(arr))
xTimeValue = xTimeValue & "-" & Val(vallue) + Val(timearr(UBound(arr)))
End If
If gtri = True Then
Congdoan_Time = text
Else
Congdoan_Time = xTimeValue
End If
End Function
Formula at Sumary Steps Column
at Sumary Values Column
Please help to make another funtion that's work for me
Thank you

Answer 1

My two cents using a dictionary:
Function Summary(steps As String, vals As String, pick As Boolean) As String
Dim arr_steps As Variant, arr_vals As Variant
Dim new_steps() As Variant, new_vals() As Variant
arr_steps = Split(steps, ",")
arr_vals = Split(vals, "-")
ReDim new_steps(UBound(arr_steps))
ReDim new_vals(UBound(arr_steps))
For x = 0 To UBound(arr_steps)
If x = 0 Then
new_steps(x) = arr_steps(x)
new_vals(x) = arr_vals(x)
ElseIf arr_steps(x) = arr_steps(x - 1) Then
new_vals(x) = CDbl(new_vals(x - 1)) + CDbl(arr_vals(x))
new_vals(x - 1) = ""
Else
new_steps(x) = arr_steps(x)
new_vals(x) = arr_vals(x)
End If
Next
If pick Then
Summary = Join(new_steps, ",")
Else
Summary = Join(new_vals, "-")
End If
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "(?:^-+|[-,]+([-,])|,+$)"
Summary = .Replace(Summary, "$1")
End With
End Function
Formula in C1:
=Summary(A1,B1,1)
Formula in D1:
=Summary(A1,B1,0)
Note: My locale uses decimal-comma instead of point. It should work out fine if yours is using dots. I just had to change these in the input.

Answer 2

I'm not sure I fully understand the question but looking at your examples it looks like you want to deduplicate a comma delimited string but only where duplicates are in series. Something like this does that quite optimally:
Function SerialDedupe(ByVal s As String) As String
Dim v: v = Split(s, ",")
Dim iLB As Long: iLB = LBound(v)
Dim index As Long: index = iLB
Dim i As Long
For i = iLB + 1 To UBound(v)
If v(i) <> v(index) Then
index = index + 1
v(index) = v(i)
End If
Next
ReDim Preserve v(iLB To index)
SerialDedupe = Join(v, ",")
End Function
Tests:
1,2,2,2,3,3,2 ==> 1,2,3,2
A,B,B,C,B,B,C,D,B,C,B,A,A,B ==> A,B,C,B,C,D,B,C,B,A,B
1,2,2 ==> 1,2
1,1,2 ==> 1,2
1,2 ==> 1,2
1 ==> 1