Function to summarize text in Vba Excel-CodePudding

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

CodePudding user response：

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.

CodePudding user response：

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