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]

Option Compare Text
Sub Test()
  Dim lRow As Long
  lRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 6 To lRow
    If InStr(Cells(i, 1).Value, Cells(3, 2).Value) > 0 Then
      myArr = Split(Cells(i, 1).Value, "*")
      For j = 0 To UBound(myArr)
        If myArr(j) Like "*" & Cells(3, 2).Value & "*" Then
          Cells(i, 2).Value = Cells(i, 2).Value + myArr(j + 1)
        End If
      Next
      Else
       Cells(i, 2).Value = 0
    End If
  Next
End Sub

 

[Excelpromax123]

Option Compare Text
Sub Test()
  Dim lRow As Long
  lRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 6 To lRow
    If InStr(Cells(i, 1).Value, Cells(3, 2).Value) > 0 Then
      myArr = Split(Cells(i, 1).Value, "*")
      For j = 0 To UBound(myArr)
        If myArr(j) Like "*" & Cells(3, 2).Value & "*" Then
          Cells(i, 2).Value = Cells(i, 2).Value + myArr(j + 1)
        End If
      Next
      Else
       Cells(i, 2).Value = 0
    End If
  Next
End Sub

Thank you for your help. I see the code is correct only when running the code for 1 first time, when running the code for the 2nd, 3rd time.. onwards, it adds wrong. You can fix it to help me run the code as many times as possible and still get the same result as the first time. Please help me fix the Cells property to Range so that I can adjust the input easily. For example Range("A1:A100") because the file itself is located in a different area for example: J5:J100 . Thank you very much

 

[Legacy 143009]

Like tihs?

Option Compare Text
Sub Test()
  Dim lRow As Long
  lRow = Range("A6").End(xlDown).Row
  Range("B6:B" & lRow).ClearContents
  For i = 6 To lRow
    If InStr(Range("A" & i).Value, Range("B3").Value) > 0 Then
      myArr = Split(Range("A" & i).Value, "*")
      For j = 0 To UBound(myArr)
        If myArr(j) Like "*" & 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

 

[Excelpromax123]

Like tihs?

Option Compare Text
Sub Test()
  Dim lRow As Long
  lRow = Range("A6").End(xlDown).Row
  Range("B6:B" & lRow).ClearContents
  For i = 6 To lRow
    If InStr(Range("A" & i).Value, Range("B3").Value) > 0 Then
      myArr = Split(Range("A" & i).Value, "*")
      For j = 0 To UBound(myArr)
        If myArr(j) Like "*" & 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

Thank you. You gave your correct answer. I want to delete this line "Option Compare Text" Replace "UCASE", how to do?

 

[Peter_SSs]

What about a user-defined function like this?

Function HT(s As String, txt As String) As Double
  Dim RX As Object, M As Object
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  RX.Pattern = "(;" & txt & "\*[\d.]+)(?=\D)"
  For Each M In RX.Execute(";" & s)
    HT = HT + Split(M, "*")(1)
  Next M
End Function

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

Cell Formulas
Range	Formula
B6:B9	B6	=HT(A6,B$3)

 

[Legacy 143009]

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

 

[Fluff]

There si no need to use Ucase, instr allows you to specify text comparison like

InStr(1, Range("A" & i).Value, Range("B3").Value, vbTextCompare) > 0

 

[Excelpromax123]

What about a user-defined function like this?

Function HT(s As String, txt As String) As Double
  Dim RX As Object, M As Object
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  RX.Pattern = "(;" & txt & "\*[\d.]+)(?=\D)"
  For Each M In RX.Execute(";" & s)
    HT = HT + Split(M, "*")(1)
  Next M
End Function

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

Cell Formulas
Range	Formula
B6:B9	B6	=HT(A6,B$3)

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

 

[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

Thank you for helping me. I wish you a nice day. I'm trying to code about 100,000 lines, the code runs quite slow. Now that you develop more Dictionary format code, that's great. Thank you