Copy text value from one cell to another if all criterias are met

[zack8576]

If column O is exactly "Sanitary", I need to add up all the numbers in L that are on the same rows that contain partial keywords: "Base", "Riser", "Cone", "Adjustment", "Ring" in column K
AND contain the same value in column B. so in the sample data below, rows 21,22,23,24,25 meets all requirements. and 36 + 32 + 18 + 7 + 7 = 100"

next I need to convert this number to feet, in this case it is 8.33'

Then I need to check what range in column T this number falls into, in example data below, it is matching the range on row 3.

the final step is to copy value from U on the row with matching range, into H with same value on B, and contain partial keyword "Base"
Note: the value in U is always text value, and it always has a dollar sign in front of the number. and the dollar sign needs to be removed. so H21 should be 3491.00

my code is able to do all the above, except the last step, instead of copying the correct dollar amount to H, code is turning H into a blank cell (it had 0 in the cell by default)
code below, any help is appreciated !

Sub Sanitary()
    Dim lastRow As Long
    Dim dict As Object
    Dim key As Variant
    Dim Value As Variant
    Dim Values As Variant
    Dim total As Double
    Dim i As Long
    Dim regex As Object
    Dim matches As Object
    Dim Match As Object
    Set dict = CreateObject("Scripting.Dictionary")

    lastRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
    For i = 2 To lastRow
        If InStr(ActiveSheet.Cells(i, 15), "Sanitary") > 0 Then
            If InStr(1, ActiveSheet.Cells(i, 11), "Base") > 0 Or _
               InStr(1, ActiveSheet.Cells(i, 11), "Riser") > 0 Or _
               InStr(1, ActiveSheet.Cells(i, 11), "Cone") > 0 Or _
               InStr(1, ActiveSheet.Cells(i, 11), "Adjustment") > 0 Or _
               InStr(1, ActiveSheet.Cells(i, 11), "Ring") > 0 Then
                key = ActiveSheet.Cells(i, 2)
                Values = Split(ActiveSheet.Cells(i, 12), ",")
                total = 0
                For Each Value In Values
                    Set regex = CreateObject("VBScript.RegExp")
                    regex.Pattern = "(\d+)"
                    regex.Global = True
                    Set matches = regex.Execute(Value)
                    For Each Match In matches
                        If IsNumeric(Match) Then
                            total = total + Match
                        End If
                    Next Match
                Next Value
                If dict.exists(key) Then
                    dict(key) = dict(key) + total
                Else
                    dict.Add key, total
                End If
            End If
        End If
    Next i
    For i = 2 To lastRow
        If InStr(ActiveSheet.Cells(i, 15), "Sanitary") > 0 Then
            If InStr(1, ActiveSheet.Cells(i, 11), "Base") > 0 Then
                Dim valueU As String
                valueU = Replace(ActiveSheet.Cells(i, 21), "$", "")
                ActiveSheet.Cells(i, 8).Value = valueU
            End If
         End If
    Next i
End Sub

 

[bebo021999]

Try to attach a mini sheet via XL2BB (XL2BB - Excel Range to BBCode) or spreadsheet via gg drive, dropbox...

 

[zack8576]

here is a small sample file, in this file, H21, H34 meet all criterias, and the value in U3 should be copied to these 2 cells

2023010036 SANITARY.csv

Shared with Dropbox

www.dropbox.com

 

[zack8576]

this modified code copies the dollar sign over, but not the number ....

Sub Sanitary()
    Dim lastRow As Long
    Dim dict As Object
    Dim key As Variant
    Dim value As Variant
    Dim values As Variant
    Dim total As Double
    Dim i As Long
    Dim regex As Object
    Dim matches As Object
    Dim match As Object
    Dim ranges As Variant
    Dim rangeValue As String
    Dim j As Long

    Set dict = CreateObject("Scripting.Dictionary")

    lastRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
    For i = 2 To lastRow
        If InStr(ActiveSheet.Cells(i, 15), "Sanitary") > 0 Then
            If InStr(1, ActiveSheet.Cells(i, 11), "Base") > 0 Or _
               InStr(1, ActiveSheet.Cells(i, 11), "Riser") > 0 Or _
               InStr(1, ActiveSheet.Cells(i, 11), "Cone") > 0 Or _
               InStr(1, ActiveSheet.Cells(i, 11), "Adjustment") > 0 Or _
               InStr(1, ActiveSheet.Cells(i, 11), "Ring") > 0 Then
                key = ActiveSheet.Cells(i, 2)
                values = Split(ActiveSheet.Cells(i, 12), ",")
                total = 0
                For Each value In values
                    Set regex = CreateObject("VBScript.RegExp")
                    regex.Pattern = "(\d+\/\d+')"
                    regex.Global = True
                    Set matches = regex.Execute(value)
                    For Each match In matches
                        If IsNumeric(match) Then
                            total = total + match
                        End If
                    Next match
                Next value
                If dict.exists(key) Then
                    dict(key) = dict(key) + total
                Else
                    dict.Add key, total
                End If
            End If
        End If
    Next i

    For i = 2 To lastRow
        If InStr(ActiveSheet.Cells(i, 15), "Sanitary") > 0 Then
            If InStr(1, ActiveSheet.Cells(i, 11), "Base") > 0 Then
                rangeValue = ""
                ranges = Split(ActiveSheet.Cells(i, 20), ",")
                For j = 0 To UBound(ranges)
                    If total >= CDbl(Split(ranges(j), "/")(0)) And total < CDbl(Split(ranges(j), "/")(1)) Then
                        rangeValue = rangeValue & "-$" & Format(CDbl(Replace(ActiveSheet.Cells(i, 21), ",", "")), "#,##0")
                        Exit For
                    End If
                Next j
                ActiveSheet.Cells(i, 8).value = "$" & WorksheetFunction.Substitute(rangeValue, ",", "")
            End If
        End If
    Next i
End Sub