TOTAL VALUE BY CODE IN 1 CHAIN. USE VBA CODE

[Excelpromax123]

Hello everyone. I have a data range A6:A11. I want to accumulate a mutable sequence value in cell B3. I want to use Vba code for fast processing because my data is quite long. I sincerely thank !

Loading Google Sheets

 

[Legacy 143009]

Dictionaries are not the fastest things always. Why are you obsessed with them so badly?
This is as far as I can push. Good luck if you are looking for a faster solution with a dictionary.

Sub Test()
  Dim lRow As Long, myStr As String
  lRow = Range("A6").End(xlDown).Row
  Range("B6:B" & lRow).ClearContents
  myArr = Range("A6:B" & lRow)
  myStr = UCase(Range("B3").Value)
  For i = 1 To UBound(myArr)
    If InStr(1, myArr(i, 1), myStr, vbTextCompare) > 0 Then
      temp = Split(myArr(i, 1), "*")
      For j = 0 To UBound(temp)
        If UCase(temp(j)) Like "*" & myStr & "*" Then
         myArr(i, 2) = myArr(i, 2) + Val(temp(j + 1))
        End If
      Next
    End If
  Next
  Application.ScreenUpdating = False
  For i = 6 To lRow
    Range("B" & i).Value = CDbl(myArr(i - 5, 2))
  Next
  Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

Thank you for helping me. Can you edit the code in the form of Sub to help me. Because my data is 100,000 lines, it completes this function, the machine runs quite slowly. Please take a moment to help me with the fastest code, such as Dictionary

Give this worksheet change event macro a test with a copy of your workbook. To implement ..
1. Right click the sheet name tab and choose "View Code".
2. Copy and Paste the code below into the main right hand pane that opens at step 1.
3. Close the Visual Basic window & test by entering a different value in cell B3 (or clearing that cell).

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim RX As Object, M As Object
  Dim a As Variant
  Dim txt As String
  Dim i As Long
  Dim Ht As Double
 
  If Not Intersect(Target, Range("B3")) Is Nothing Then
    Range("B6", Range("B" & Rows.Count).End(xlUp).Offset(1)).ClearContents
    txt = Range("B3").Value
    If Len(txt) > 0 Then
      Set RX = CreateObject("VBScript.RegExp")
      RX.Global = True
      RX.IgnoreCase = True
      RX.Pattern = "(;|^)(" & txt & "\*[\d.]+)(?=\D|$)"
      a = Range("A6", Range("A" & Rows.Count).End(xlUp)).Value
      For i = 1 To UBound(a)
        Ht = 0
        For Each M In RX.Execute(a(i, 1))
          Ht = Ht + Split(M, "*")(1)
        Next M
        a(i, 1) = Ht
      Next i
      Range("B6").Resize(UBound(a)).Value = a
    End If
  End If
End Sub

 

[Excelpromax123]

Sub Test()
  Dim lRow As Long
  lRow = Range("A6").End(xlDown).Row
  Range("B6:B" & lRow).ClearContents
  For i = 6 To lRow
    If InStr(UCase(Range("A" & i).Value), UCase(Range("B3").Value)) > 0 Then
      myArr = Split(Range("A" & i).Value, "*")
      For j = 0 To UBound(myArr)
        If UCase(myArr(j)) Like "*" & UCase(Range("B3").Value) & "*" Then
         Range("B" & i).Value = Range("B" & i).Value + myArr(j + 1)
        End If
      Next
      Else
       Range("B" & i).Value = 0
    End If
  Next
End Sub

Have a nice day

Sorry to bother you now. I just tried it, if the numeric value is a Negative number, the result is incorrect. I hope you can correct the code for me. thank you very much

 

[Peter_SSs]

For my suggestion, to allow for negative numbers, a slight variation is required

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim RX As Object, M As Object
  Dim a As Variant
  Dim txt As String
  Dim i As Long
  Dim Ht As Double
  
  If Not Intersect(Target, Range("B3")) Is Nothing Then
    Range("B6", Range("B" & Rows.Count).End(xlUp).Offset(1)).ClearContents
    txt = Range("B3").Value
    If Len(txt) > 0 Then
      Set RX = CreateObject("VBScript.RegExp")
      RX.Global = True
      RX.IgnoreCase = True
      RX.Pattern = "(;|^)(" & txt & "\*\-?[\d.]+)(?=\D|$)"
      a = Range("A6", Range("A" & Rows.Count).End(xlUp)).Value
      For i = 1 To UBound(a)
        Ht = 0
        For Each M In RX.Execute(a(i, 1))
          Ht = Ht + Split(M, "*")(1)
        Next M
        a(i, 1) = Ht
      Next i
      Range("B6").Resize(UBound(a)).Value = a
    End If
  End If
End Sub

 

[Legacy 143009]

Dictionaries are not the fastest things always. Why are you obsessed with them so badly?
This is as far as I can push. Good luck if you are looking for a faster solution with a dictionary.

Sub Test()
  Dim lRow As Long, myStr As String
  lRow = Range("A6").End(xlDown).Row
  Range("B6:B" & lRow).ClearContents
  myArr = Range("A6:B" & lRow)
  myStr = UCase(Range("B3").Value)
  For i = 1 To UBound(myArr)
    If InStr(1, myArr(i, 1), myStr, vbTextCompare) > 0 Then
      temp = Split(myArr(i, 1), "*")
      For j = 0 To UBound(temp)
        If UCase(temp(j)) Like "*" & myStr & "*" Then
         myArr(i, 2) = myArr(i, 2) + Val(temp(j + 1))
        End If
      Next
    End If
  Next
  Application.ScreenUpdating = False
  For i = 6 To lRow
    Range("B" & i).Value = CDbl(myArr(i - 5, 2))
  Next
  Application.ScreenUpdating = True
End Sub

You are using the wrong code. The code above considers negative numbers.

 

[Peter_SSs]

The code above considers negative numbers.

.. but it may return incorrect results, depending on what data is possible. For example, column B here was generated by your post 11 code.

Excelpromax123.xlsm
	A	B
3	Text ( Change the string here ) ------>	ABC
4
5	String	HEIGHT
6	ABC*10.5*5250;ADD*5*800;AABCC*6*125;	16.5
7	CCBA*10.5*5250;ADD*5*800;Abc*6*125;	6
8	abc*-5.5*5250;ADD*5*800;ABC*6*125;	0.5
9	adv*5.5*5250;ADD*5*800;ABde*6*125;	0
Sheet1 (2)

 

[Peter_SSs]

.. but it may return incorrect results,

Well, I must admit that it is my assumption that cell B6 above is incorrect, as such a circumstance or its result has not been specified by the OP.

 

[Legacy 143009]

Thanks for the different scenario. Removing the second wildcard may fix the problem maybe.

If UCase(temp(j)) Like "*" & myStr Then

Anyways, OP has started a new thread with a completely different code. I'm not following up this topic anymore.