Macro Please

[Dazzawm]

Within any cell stretching from 1 to 10000 I have the data '90Bhp or 150Bhp' etc. What I need is a macro to take those out of that cell and put it in another cell as below.

These maybe amongst any text anywhere within the cell so text to columns will be tricky.


Sheet1

<TABLE style="BACKGROUND-COLOR: #ffffff; PADDING-LEFT: 2pt; PADDING-RIGHT: 2pt; FONT-FAMILY: Calibri,Arial; FONT-SIZE: 11pt" border=1 cellSpacing=0 cellPadding=0><COLGROUP><COL style="WIDTH: 30px"><COL style="WIDTH: 230px"></COLGROUP><TBODY><TR style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt"><TD> </TD><TD>A</TD></TR><TR style="HEIGHT: 18px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">1</TD><TD>Before</TD></TR><TR style="HEIGHT: 18px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">2</TD><TD>This 90Bhp cell has</TD></TR><TR style="HEIGHT: 18px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">3</TD><TD>This cell has 115Bhp 130Bhp 175Bhp</TD></TR><TR style="HEIGHT: 18px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">4</TD><TD>This cell has 250Bhp</TD></TR></TBODY></TABLE>

<TABLE style="BACKGROUND-COLOR: #ffffff; PADDING-LEFT: 2pt; PADDING-RIGHT: 2pt; FONT-FAMILY: Calibri,Arial; FONT-SIZE: 11pt" border=1 cellSpacing=0 cellPadding=0><COLGROUP><COL style="WIDTH: 30px"><COL style="WIDTH: 230px"><COL style="WIDTH: 151px"></COLGROUP><TBODY><TR style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt"><TD> </TD><TD>A</TD><TD>B</TD></TR><TR style="HEIGHT: 18px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">8</TD><TD>After</TD><TD> </TD></TR><TR style="HEIGHT: 18px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">9</TD><TD>This cell has</TD><TD>90Bhp</TD></TR><TR style="HEIGHT: 18px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">10</TD><TD>This cell has</TD><TD>115Bhp 130Bhp 175Bhp</TD></TR><TR style="HEIGHT: 18px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">11</TD><TD>This cell has</TD><TD>250Bhp</TD></TR></TBODY></TABLE>

 

[GTO]

Is it always 2-3 numbers jammed up (ie-no spaces) against 'Bhp'? (which I'm guessing is Brake Horsepower?)

 

[Dazzawm]

Yes it is but there may be engine numbers etc within the cell so I just need to 'cut' out any 'Bhps' and leave everything else there.

 

[GTO]

Okay, this would be more critical then: "2-3 numbers jammed up (ie-no spaces)"

Can we count on no space between the digit(s) and 'Bhp'?

Could you post some sample data?

 

[Dazzawm]

No there will never be a gap between digit and bhp. Sample below.

<TABLE style="BACKGROUND-COLOR: #ffffff; PADDING-LEFT: 2pt; PADDING-RIGHT: 2pt; FONT-FAMILY: Arial,Arial; FONT-SIZE: 10pt" border=1 cellSpacing=0 cellPadding=0><COLGROUP><COL style="WIDTH: 30px"><COL style="WIDTH: 434px"></COLGROUP><TBODY><TR style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt"><TD> </TD><TD>K</TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">461</TD><TD>Engine 260Bhp AKC AQG </TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">462</TD><TD>Engine ABZ AKG 300Bhp</TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">463</TD><TD>Engine 310Bhp AUW AQF 310Bhp</TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">464</TD><TD>Engine AUW AQF 310Bhp</TD></TR></TBODY></TABLE>

 

[GTO]

Excel Workbook
	A	B
1	HEADER	HEADER
2	Engine 260Bhp AKC AQG	260Bhp
3	Engine ABZ AKG 300Bhp	300Bhp
4	Engine 310Bhp AUW AQF 310Bhp	310Bhp 310Bhp
5	Engine AUW AQF 310Bhp	310Bhp
Sheet1

Excel 2003

Try, In a Standard Module:

Option Explicit
    
Sub exa()
Dim REX         As Object '<--- RegExp
Dim rexMatch    As Object '<--- Match
Dim rexMatchCol As Object '<--- MatchCollection
Dim Cell        As Range
Dim strText     As String
    
    Set REX = CreateObject("VBScript.RegExp")
    With REX
        .Global = True
        .IgnoreCase = False '<---change to suit if any 'bhp' / 'BHP' etc
        .Pattern = "\b[0-9]+Bhp\b"
        
        For Each Cell In Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp))
            If .Test(Cell.Value) Then
                Set rexMatchCol = .Execute(Cell.Value)
                strText = vbNullString
                For Each rexMatch In rexMatchCol
                    strText = strText & Chr(32) & rexMatch.Value
                Next
                Cell.Offset(, 1).Value = Trim(strText)
            End If
        Next
    End With
End Sub

Please note that I did not qualify the range etc, but would in the actual project. Please try in a junk copy of your wb first.

Hope that helps,

Mark

 

[Dazzawm]

Thanks thats almost there but they are staying in the original cell where I want them removed altogether.

 

[GTO]

Oopsie, I missed that part.

Option Explicit
    
Sub exa()
Dim REX         As Object '<--- RegExp
Dim rexMatch    As Object '<--- Match
Dim rexMatchCol As Object '<--- MatchCollection
Dim Cell        As Range
Dim strText     As String
    
    Set REX = CreateObject("VBScript.RegExp")
    With REX
        .Global = True
        .IgnoreCase = False '<---change to suit if any 'bhp' / 'BHP' etc
        .Pattern = "\b[0-9]+Bhp\b"
        
        For Each Cell In Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp))
            If .Test(Cell.Value) Then
                Set rexMatchCol = .Execute(Cell.Value)
                Cell.Value = .Replace(Cell.Value, vbNullString)
                strText = vbNullString
                For Each rexMatch In rexMatchCol
                    strText = strText & Chr(32) & rexMatch.Value
                Next
                Cell.Offset(, 1).Value = Trim(strText)
            End If
        Next
    End With
End Sub

 

[Dazzawm]

Thats quality thanks so much.

 

[GTO]

Glad to help