VBA If specific string is matched display top cell and left most cell

[excelboi]

Hello,

I have been trying to solve a problem through VBA but i am not getting desired output.
For example if any search function found the string "(1) " then the selected cells ID, variable and cell should be displayed. The following is the sample table

ID	tstrt	dur
1
2	(1) 845 (2) 79
3		(1) 4 (2) 6
4	(1) 987 (2) 556	(1) 25 (2) 35

<tbody>
</tbody>

Desired output in new column

ID	tstrt	tend	OUTPUT
1
2	(1) 845 (2) 79		2 tstrt (1) 845 (2) 79
3		(1) 4 (2) 6	3 tend (1) 4 (2) 6
4	(1) 987 (2) 556	(1) 25 (2) 35	4 tstrt (1)987 (2) 556 4 tend (1)25 (2) 35

<tbody>
</tbody>

Thank you for your time. I will be very thankful if any one can help me on this.

 

[RCBricker]

This should work. Tested against your example data and it ends up looking like your desired output.

Sub excelboi()
Dim ws As Worksheet
Dim lngROW As Long, lngCOL As Long
Dim rng As Range, cell As Range
Dim first As Variant

Set ws = Sheets("excelboi")

With ws
    lngROW = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    lngCOL = ws.cells(1, ws.Columns.Count).End(xlToLeft).Offset(, 1).Column
    ws.cells(1, lngCOL).Value = "Output"
    
    Set rng = ws.Range(ws.cells(1, 1), ws.cells(lngROW, lngCOL - 1))
    Set cell = rng.Find("*(1) *", ws.cells(1, 1))
     If Not cell Is Nothing Then
        first = cell.Address
        Do
            If ws.cells(cell.Row, 4).Value = "" Then
            ws.cells(cell.Row, 4).Value = ws.cells(cell.Row, 1).Value & " " _
                & ws.cells(1, cell.Column).Value & " " & cell.Value
            Else
                ws.cells(cell.Row, 4).Value = ws.cells(cell.Row, 4).Value & _
                    Chr(10) & ws.cells(cell.Row, 1).Value & " " & _
                    ws.cells(1, cell.Column).Value & " " & cell.Value
            End If
            Set cell = rng.FindNext(cell)
        Loop While Not cell Is Nothing And Not cell.Address = first
     End If
     ws.Columns.ColumnWidth = 100
     ws.Columns.AutoFit
     ws.Rows.AutoFit
End With

 

[excelboi]

I have run the above code but its not working

Runtime error 9:
subscript out of range

This should work. Tested against your example data and it ends up looking like your desired output.

Sub excelboi()
Dim ws As Worksheet
Dim lngROW As Long, lngCOL As Long
Dim rng As Range, cell As Range
Dim first As Variant

Set ws = Sheets("excelboi")

With ws
    lngROW = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    lngCOL = ws.cells(1, ws.Columns.Count).End(xlToLeft).Offset(, 1).Column
    ws.cells(1, lngCOL).Value = "Output"
    
    Set rng = ws.Range(ws.cells(1, 1), ws.cells(lngROW, lngCOL - 1))
    Set cell = rng.Find("*(1) *", ws.cells(1, 1))
     If Not cell Is Nothing Then
        first = cell.Address
        Do
            If ws.cells(cell.Row, 4).Value = "" Then
            ws.cells(cell.Row, 4).Value = ws.cells(cell.Row, 1).Value & " " _
                & ws.cells(1, cell.Column).Value & " " & cell.Value
            Else
                ws.cells(cell.Row, 4).Value = ws.cells(cell.Row, 4).Value & _
                    Chr(10) & ws.cells(cell.Row, 1).Value & " " & _
                    ws.cells(1, cell.Column).Value & " " & cell.Value
            End If
            Set cell = rng.FindNext(cell)
        Loop While Not cell Is Nothing And Not cell.Address = first
     End If
     ws.Columns.ColumnWidth = 100
     ws.Columns.AutoFit
     ws.Rows.AutoFit
End With

 

[excelboi]

Got it, had to change the sheet name into "excelboi" now its working
Thank you for your time and effort.