Unable to search and replace the values using column headers

Question

I'm trying to create a vba script that will search for the _ in all the cells fallen under Crude Items column. However, when it finds one, it will split the values from _ and place the rest in corresponding cells fallen under Refined Ones column.

I've tried with the following which is doing the job flawlessly but I wish to search and replace the values using column headers:

Sub CopyAndReplace()
    Dim cel As Range

    For Each cel In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).row)
        If cel.value <> "" Then
            Sheets("Sheet1").Range(cel(1, 3).Address) = Split(cel, "_")(1)
        End If
    Next cel
End Sub

To let you visualize how the sheet might look like:

How can I search and replace the values using column headers?

Answer 1

If you are working through an actual table things will become quite easy:

Sub Test()

Dim arr(), x As Long
With ThisWorkbook.Sheets("Sheet1") 'Change accordingly
    For Each cl In .Range("Table1[Crude Items]") 'Change Table1 accordingly
         ReDim Preserve arr(x)
         If InStr(cl, "_") > 0 Then
             arr(x) = Split(cl, "_")(1)
         Else
            arr(x) = ""
         End If
         x = x + 1
    Next cl
    .Range("Table1[Refined Ones]").Value = Application.Transpose(arr)
End With

End Sub

There is a check for "_". If not there, the cell will be kept empty.

Answer 2

For fun using regex and dynamically finding header columns. You can swop out the regex based function for your own and still have the dynamic column finding.

Option Explicit
Public Sub test()
    Dim i As Long, inputs(), re As Object, ws As Worksheet
    Dim inputColumn As Range, outputColumn As Range, inputColumnNumber As Long, outputColumnNumber As Long
    Const SEARCH_ROW As Long = 1
    Const INPUT_HEADER As String = "Crude items"
    Const OUTPUT_HEADER As String = "Refined Ones"
    Const START_ROW = 2

    Set re = CreateObject("VBScript.RegExp")
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set inputColumn = GetColumnByHeader(ws, SEARCH_ROW, INPUT_HEADER)
    Set outputColumn = GetColumnByHeader(ws, SEARCH_ROW, OUTPUT_HEADER)

    If inputColumn Is Nothing Or outputColumn Is Nothing Then Exit Sub

    inputColumnNumber = inputColumn.Column
    outputColumnNumber = outputColumn.Column

    With ws
        inputs = Application.Transpose(.Range(.Cells(START_ROW, inputColumnNumber), .Cells(.Cells(.Rows.Count, inputColumnNumber).End(xlUp).Row, inputColumnNumber)).Value)
        For i = LBound(inputs) To UBound(inputs)
            inputs(i) = GetMatch(re, inputs(i))
        Next
        .Cells(START_ROW, outputColumnNumber).Resize(UBound(inputs), 1) = Application.Transpose(inputs)
    End With
End Sub

Public Function GetColumnByHeader(ByVal ws As Worksheet, ByVal SEARCH_ROW As Long, ByVal columnName As String) As Range
    Set GetColumnByHeader = ws.Rows(SEARCH_ROW).Find(columnName)
End Function

Public Function GetMatch(ByVal re As Object, ByVal inputString As String) As String
    With re
        .Global = True
        .MultiLine = True
        .Pattern = "_(.*)"

        If .test(inputString) Then
            GetMatch = .Execute(inputString)(0).SubMatches(0)
        Else
            GetMatch = inputString  'or =vbNullString if want to return nothing
        End If
    End With
End Function

Answer 3

I am not clear about what you want to replace "_" character with. For example, iff you replace the following line of your script:

Sheets("Sheet1").Range(cel(1, 3).Address) = Split(cel, "_")(1)

with this one:

Sheets("Sheet1").Range(cel(1, 3).Address) = WorksheetFunction.Substitute(cel, "_", "")

The above line should replace the "_" character with nothing from the cells in the Crude_Items column

And as Lee said, you can also consider using formula in the worksheet if you do not have significant amount of data

Answer 4

I have just tried this one with the code below:

It is a good idea to add additional check to the condition, like this - If myCell.Value <> "" And InStr(1, myCell, "_") Then to avoid starting from A2.

The idea is that the LocateValueCol locates the column of the first row, which has the string, passed to it. Knowing this, it works ok.

Option Explicit

Sub CopyAndReplace()

    Dim searchColumn As Long
    searchColumn = LocateValueCol("SearchCol", Worksheets(1))

    Dim replaceColumn As Long
    replaceColumn = LocateValueCol("ReplaceCol", Worksheets(1))

    Dim myCell As Range
    Dim lastCell As Long

    With Worksheets(1)
        lastCell = .Cells(.Rows.Count, searchColumn).End(xlUp).Row
        For Each myCell In .Range(.Cells(1, searchColumn), .Cells(lastCell, searchColumn))
            If myCell.Value <> "" And InStr(1, myCell, "_") Then
                .Cells(myCell.Row, replaceColumn) = Split(myCell, "_")(1)
            End If
        Next
    End With

End Sub

This is the function, locating the columns. (If you have ideas for improvement, feel free to make a PR here):

Public Function LocateValueCol(ByVal textTarget As String, _
                ByRef wksTarget As Worksheet, _
                Optional rowNeeded As Long = 1, _
                Optional moreValuesFound As Long = 1, _
                Optional lookForPart = False, _
                Optional lookUpToBottom = True) As Long

    Dim valuesFound As Long
    Dim localRange  As Range
    Dim myCell  As Range

    LocateValueCol = -999
    valuesFound = moreValuesFound
    Set localRange = wksTarget.Range(wksTarget.Cells(rowNeeded, 1), wksTarget.Cells(rowNeeded, Columns.Count))

    For Each myCell In localRange
        If lookForPart Then
            If textTarget = Left(myCell, Len(textTarget)) Then
                If valuesFound = 1 Then
                    LocateValueCol = myCell.Column
                    If lookUpToBottom Then Exit Function
                Else
                    Decrement valuesFound
                End If
            End If
        Else
            If textTarget = Trim(myCell) Then
                If valuesFound = 1 Then
                    LocateValueCol = myCell.Column
                    If lookUpToBottom Then Exit Function
                Else
                    Decrement valuesFound
                End If
            End If
        End If
    Next myCell

End Function

Private Sub Increment(ByRef valueToIncrement As Variant, Optional incrementWith As Double = 1)

    valueToIncrement = valueToIncrement + incrementWith

End Sub

Private Sub Decrement(ByRef valueToDecrement As Variant, Optional decrementWith As Double = 1)

    valueToDecrement = valueToDecrement - decrementWith

End Sub

Answer 5

You can also consider to use formula to do it.

Answer 6

I am not sure this is what you are after, but a few important mentions...

Try to always use at least a worksheet qualifier when writing your code. How else is your program going to know explicitly where you would like it to operate?

I have changed your process slightly, but again, not sure if this is exactly what you are after. See below code.

Sub SplitByHeader()

    Dim i As Long
    Dim crudeHeader As Range, refinedHeader As Range
    Dim ws As Worksheet


    'set ws
    Set ws = ThisWorkbook.Sheets("Sheet1")

    'set header ranges
    Set crudeHeader = ws.Rows(1).Find(What:="Crude Items", LookAt:=xlWhole)
    Set refinedHeader = ws.Rows(1).Find(What:="Refined Ones", LookAt:=xlWhole)

    'simple error handler
    If crudeHeader Is Nothing Or refinedHeader Is Nothing Then Exit Sub


    For i = 2 To ws.Cells(ws.Rows.Count, crudeHeader.Column).End(xlUp).Row
        If ws.Cells(i, crudeHeader.Column).Value <> "" Then
            ws.Cells(i, refinedHeader.Column).Value = Split(ws.Cells(i, crudeHeader.Column).Value, "_")(1)
        End If
    Next i


End Sub