Create a macro using Find and Replace with SUBSTITUTE referencing the ActiveCell address

[creases]

I have this range of data, which is a takeoff of engineered wood products. This is just a small excerpt of a spreadsheet that gets produced from an AutoCAD program I use. For clarify, I didn't show all of this, but normally there can be at least 2 or 3 other ranges of data inserted above, with each range separated by a row of blank cells. The number of Columns are fixed, but the start of the range can occur on different Row numbers. What I would like to do is create a macro that will Find and Replace All the three different values (“-“, “STD.” and “1/16””) in Column A (“MARK”) with a new abbreviated mark, based on the values of Column D (“DIMENSIONS”) and Column E (“GRADE”).

I would like the new abbreviated mark to follow this nomenclature:

For all occurrences of “-“ or “STD.”, the new abbreviated mark should read:

“Abbrev. Dimensions of the beam + Abbrev. Grade”
Dimensions (only includes the whole number from the width and height of the beam)
3 1/2” X 11 7/8” = “311”

Grade:
2.0E = “LVL”
1.55E = “LSL”
30F-E2 = “BB”
24F-V4 = “GLB”

Example for Cell “A4” = “311LVL”

For all occurrences of “1/16””, the new abbreviated mark should read:
“Abbrev. Dimensions + “HDR”

Example for Cell “A8” = “511HDR”


I first approached this by trying to use the SUBSTITUTE function because I knew I’d be able to utilize and manipulate the existing text to create the new abbreviated mark that I wanted.

So with SUBSTITUTE nested several times, I combined the cell values from Column D and Column E, and removed all spaces, fractions with the inches symbol (in this data set those are quotation marks), and replaced the grade with the abbreviated type. This formula produces the result I want.

=SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(D4&E4," ",""),"X",""),"""",""),"1.55E","LSL"),"2.0E","LVL"),"24F-V4","GLB"),"30F-E2","BB"),"1/4",""),"1/2",""),"3/4",""),"7/8","")

The issue with this formula, is that it needs to reference a cell address (in this example, "D4&E4"), which as I mentioned above, the start of the range can occur at different Row numbers because it's entirely dependent on how much material is listed in a given project.

I was unsuccessful in trying to record this macro, and I don’t know where to start to write this out in VBA. Is it possible to use Substitute and have it reference the address based on the ActiveCell address yielded by Find?

Using SUBSTITUTE nested seems really convoluted, but as you can imagine there are so many potential combinations of beam types and beam dimensions. This seems like the simplest way to account for all the potential combinations.

I'd really appreciate any suggestions or input on this. Thanks in advance.

 

[JLGWhiz]

See if this will work. Untested.

Sub t()
Dim c As Range, spl As Variant, g1 As String, g2 As String, g3 As String, g4 As String, gr As String, m As String
g1 = "LVL"
g2 = "LSL"
g3 = "BB"
g4 = "GLB"
    With ActiveSheet
        For Each c In .Range("A4", .Cells(Rows.Count, 1).End(xlUp))
            If c <> "" And c <> "MARK" Then
                spl = Split(c.Offset(, 3).Value, " ")
                m = spl(0) & spl(3)
                If c.Value = "-" Or c = "STD" Then
                    Select Case c.Offset(, 4).Value
                        Case "2.0E"
                            gr = g1
                        Case "1.55E"
                            gr = g2
                        Case "30F-E2"
                            gr = g3
                        Case "24-V4"
                            gr = g4
                    End Select
                ElseIf c.Value = "1/16" & Chr(34) Then
                    gr = "HDR"
                End If
                c = m & gr
                c.Replace Chr(34), ""
            End If
        Next
    End With
End Sub

 

[creases]

Thank you for your response! This is working almost exactly as I need it to. One thing I noticed however is if I have a different set of data above this range, I get an error "Run-time error '9: Subscript out of range" on this line:

m = spl(0) & spl(3)

 

[JLGWhiz]

The code is based on what the OP described. If your actual data set is different, you cannot expect the code to automatically adjust. You can change the starting point on your sheet by changing the 'A4' in this line to the cell where your 'Mark' data begins.

For Each c In .Range("A4", .Cells(Rows.Count, 1).End(xlUp))

 

[creases]

Before:

Desired Results:

Sub Test1()
    Dim a, i As Long, x, myGrade As String, myRow
    myRow = Application.Match("MARK", Columns(1), 0)
    If IsError(myRow) Then MsgBox "Header form ""MARK"" not found in col.A": Exit Sub
    With Range("a" & myRow, Range("a" & Rows.Count).End(xlUp)).Resize(, 5)
        a = .Value
        For i = 2 To UBound(a, 1)
            If (a(i, 1) = "-") + (a(i, 1) = "STD.") + (a(i, 1) = "1/16" & Chr(34)) + (a(i, 1) = "1" & Chr(34)) Then
                If a(i, 1) = "1/16" & Chr(34) Then
                    myGrade = "HDR"
                ElseIf a(i, 1) = "1" & Chr(34) Then
                    myGrade = "COL"
                Else
                    Select Case a(i, 5)
                        Case "2.0E": myGrade = "LVL"
                        Case "1.55E": myGrade = "LSL"
                        Case "30F-E2": myGrade = "BB"
                        Case "24F-V4": myGrade = "GLB"
                        Case "24F-V8": myGrade = "GLB-V8"
                        Case Else: myGrade = ""
                    End Select
                End If
                x = Split(a(i, 4), "X ")
                a(i, 1) = Val(Split(x(0))(0)) & Val(Split(x(1))(0)) & myGrade
            End If
        Next
        .Value = a
    End With
End Sub

I got some assistance getting with to this point with the VBA. It's working to a certain degree. But I'm getting a subscript out of range error at this line:
a(i, 1) = Val(Split(x(0))(0)) & Val(Split(x(1))(0)) & myGrade

I am pretty sure it's the "-" in A7 and A10-A12 that is causing the subscript error. I'm not sure what to adjust in order to get the code to skip or ignore the data in Rows 1-13. I only want Column A text to to be replaced if the criteria of "Grade" is met in Column E.

 

[JLGWhiz]

Whoever helped with the code used column 4 to get the elements for your new MARK designation. Unfortunately column 4 does not always have the length and witdth dimensions and when it does not, you will get the subscript out of range error. Here is a tempoorary fix until you can get the person who helped you to take another look.

Sub Test1()
    Dim a, i As Long, x, myGrade As String, myRow
    myRow = Application.Match("MARK", Columns(1), 0)
    If IsError(myRow) Then MsgBox "Header form ""MARK"" not found in col.A": Exit Sub
    With Range("a" & myRow, Range("a" & Rows.Count).End(xlUp)).Resize(, 5)
        a = .Value
        For i = 2 To UBound(a, 1)
            If (a(i, 1) = "-") + (a(i, 1) = "STD.") + (a(i, 1) = "1/16" & Chr(34)) + (a(i, 1) = "1" & Chr(34)) Then
                If a(i, 1) = "1/16" & Chr(34) Then
                    myGrade = "HDR"
                ElseIf a(i, 1) = "1" & Chr(34) Then
                    myGrade = "COL"
                Else
                    Select Case a(i, 5)
                        Case "2.0E": myGrade = "LVL"
                        Case "1.55E": myGrade = "LSL"
                        Case "30F-E2": myGrade = "BB"
                        Case "24F-V4": myGrade = "GLB"
                        Case "24F-V8": myGrade = "GLB-V8"
                        Case Else: myGrade = ""
                    End Select
                End If
                x = Split(a(i, 4), "X ")
                On Error Resume Next
                a(i, 1) = Val(Split(x(0))(0)) & Val(Split(x(1))(0)) & myGrade
                On Error GoTo 0
                Err.Clear
            End If
        Next
        .Value = a
    End With
End Sub