VBA to extract values starting with specific character

sncb

Board Regular
Joined
Mar 17, 2011
Messages
122
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Hi all,

I paste two cells of data into A1 and B1 with different formats and spacing like below and I need to extract only those values that start with a capital 'B' and paste them below the first row in separate rows. What needs to be extracted always start with a 'B' and need to be always whole alphanumeric values like B747 or B737c.

Right now Im doing this manually, value by value and its getting very tedious. I tried with text to columns but each time the format is different and separators are different too so always end up doing it manually. Any help with VBA is really appreciated. Thank you.

Input:
1622830344926.png


Output:
1622830232979.png
 

Attachments

  • 1622829996555.png
    1622829996555.png
    15.1 KB · Views: 5

sncb

Board Regular
Joined
Mar 17, 2011
Messages
122
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Hi Marc,

This is working as expected for the data formats I displayed. Thanks for your help with this. Wish you a nice day.

Regards
Hi Marc,

This is working as expected for the data formats I displayed but when I paste other sample data like this below I also get unwanted data added like here Im getting 'test' as well which should not be there.

Test Bcode.xlsx
AB
1Boeing. 1A, B737 Airbus 1A; B707: 7 Airbus 1B; B747: 5 Baseline test Learjet 2; B717: 1 Boeing 2; B787: 2Learjet 1C;B737 | Boeing. 1;B717 | Airbus3;B747
2B737B737
3B707B717
4B747B747
5test
6B717
7B787
Sheet3



Thanks again.
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
37,054
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
Does this do what you want...
VBA Code:
Sub Bcodes()
  Dim R As Long, X As Long, Cell As Range, Arr As Variant
  For Each Cell In Range("A1", Cells(1, Columns.Count).End(xlToLeft))
    R = 0
    Arr = Split(Replace(Replace(Replace(Replace(Replace(Cell.Value, vbLf, " "), "B", ";B"), " ", " | "), ":", " "), "|", " | "), ";B")
    For X = 0 To UBound(Arr)
      If Arr(X) Like "#*" Then
        R = R + 1
        Cell.Offset(R).Value = "B" & Split(Arr(X))(0)
      End If
    Next
  Next
End Sub
 

sncb

Board Regular
Joined
Mar 17, 2011
Messages
122
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Does this do what you want...
VBA Code:
Sub Bcodes()
  Dim R As Long, X As Long, Cell As Range, Arr As Variant
  For Each Cell In Range("A1", Cells(1, Columns.Count).End(xlToLeft))
    R = 0
    Arr = Split(Replace(Replace(Replace(Replace(Replace(Cell.Value, vbLf, " "), "B", ";B"), " ", " | "), ":", " "), "|", " | "), ";B")
    For X = 0 To UBound(Arr)
      If Arr(X) Like "#*" Then
        R = R + 1
        Cell.Offset(R).Value = "B" & Split(Arr(X))(0)
      End If
    Next
  Next
End Sub
Hi Rick,

Thanks for your reply. On running the macro, only column B gets processed and not yet col A.

Test Bcode.xlsm
AB
1Airbus 3, H787 Boeing 4, H737 Learjet 4, H747 Baseline test Boom 2, H707 Airbus 2, H717Green. 3;B717 | Boeing(Brown);B747 | Airbus (Red);B737 | Airbus. 2;B787
2B717
3B747
4B737
5B787
Sheet6
 

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
37,054
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
Uh, that is because you told us to look for codes beginning with "B" when you said "What needs to be extracted always start with a 'B'". The codes in Column A for your latest post begin with a different letter. Ignore my code as it was built solely on the premise that your codes started with a "B".
 

sncb

Board Regular
Joined
Mar 17, 2011
Messages
122
Office Version
  1. 365
  2. 2010
Platform
  1. Windows

ADVERTISEMENT

Hi Rick,

My bad. I pasted some other testing data.

So this is actually working well except a small hitch. In below example Im also getting the ; and - which ideally not be included.

Book1
AB
1asdsadas, B717; asdasdas, B304; dcbvbc, B707; sfsfds. 2, B757; hjgfjhjh, B737- B707dfgfdgdf. 3;B707 | dsfggds | bvcbvc | cvbvcbvc 3;B717 | cvbvcbvc; | xvcxvxc;B747 | vcbvcbvcvc;B787
2B717;B707
3B304;B717
4B707;B747
5B757;B787
6B737-
7B707
Sheet1
 
Last edited:

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
37,054
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
Alright, give this macro a try instead...
VBA Code:
Sub Bcodes()
  Dim R As Long, X As Long, Z As Long, Cell As Range, Arr As Variant
  For Each Cell In Range("A1", Cells(1, Columns.Count).End(xlToLeft))
    R = 0
    Arr = Split(Replace(Replace(Cell.Value & "x", vbLf, " "), "B", ";B"), ";B")
    For X = 0 To UBound(Arr)
      If Arr(X) Like "#*" Then
        For Z = 1 To Len(Arr(X))
          If Mid(Arr(X), Z, 1) Like "[!0-9A-Za-z]" Then Arr(X) = Left(Arr(X), Z - 1)
        Next
        R = R + 1
        Cell.Offset(R).Value = "B" & Split(Arr(X))(0)
      End If
    Next
  Next
End Sub
 

sncb

Board Regular
Joined
Mar 17, 2011
Messages
122
Office Version
  1. 365
  2. 2010
Platform
  1. Windows

ADVERTISEMENT

Hi Rick,

Working a lot better but now an 'x' at the end of the last cell value.

BCode.xlsm
AB
1adasdsd, B707 afdasdasa. 2, B717 adfsasad 2, B319 adasdas. 1, B787 zfdsfsdf. 1, B320 dsfdsfdsf, B380 asdassa, B757 asdasdas, B797adasdsa;B717g adasdas;B707a asdasdas;B319 asdasda. 1;B340 asdasas 2;B330 sdas 1;B747a adas;B747 sdas;B747
2B707B717g
3B717B707a
4B319B319
5B787B340
6B320B330
7B380B747a
8B757B747
9B797xB747x
Sheet1



BCode.xlsm
AB
1NarrowBody - 4 - B707 NarrowBody - 2 - B717 NarrowBody - 1 - B727 MediumBody - 1 - B737c LargeBody - 1 - B747 LargeBody - 3 - B757Boeing (Green);B707 | Toulouse 2;B747| Airbus 1;B787a | Learjet 1;B717 | Boeing 1;B737 |
2B707B707
3B717B747
4B727B787a
5B737cB717
6B747B737
7B757x
Sheet1



BCode.xlsm
AB
1Airbus 3, B787 Boeing 4, B737 Learjet 4, B747 Baseline test Boom 2, B707 Airbus 2, B717Green. 3;B717 | Boeing(Brown);B747 | Airbus (Red);B737 | Airbus. 2;B787
2B787B717
3B737B747
4B747B737
5B707B787x
6B717x
Sheet1
 

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
37,054
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
Bad testing on my part.:mad: Try this version instead...
VBA Code:
Sub Bcodes()
  Dim R As Long, X As Long, Z As Long, Cell As Range, Arr As Variant
  For Each Cell In Range("A1", Cells(1, Columns.Count).End(xlToLeft))
    R = 0
    Arr = Split(Replace(Replace(Cell.Value & "@", vbLf, " "), "B", ";B"), ";B")
    For X = 0 To UBound(Arr)
      If Arr(X) Like "#*" Then
        For Z = 1 To Len(Arr(X))
          If Mid(Arr(X), Z, 1) Like "[!0-9A-Za-z]" Then Arr(X) = Left(Arr(X), Z - 1)
        Next
        R = R + 1
        Cell.Offset(R).Value = "B" & Split(Arr(X))(0)
      End If
    Next
  Next
End Sub
 
Solution

sncb

Board Regular
Joined
Mar 17, 2011
Messages
122
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Bad testing on my part.:mad: Try this version instead...
VBA Code:
Sub Bcodes()
  Dim R As Long, X As Long, Z As Long, Cell As Range, Arr As Variant
  For Each Cell In Range("A1", Cells(1, Columns.Count).End(xlToLeft))
    R = 0
    Arr = Split(Replace(Replace(Cell.Value & "@", vbLf, " "), "B", ";B"), ";B")
    For X = 0 To UBound(Arr)
      If Arr(X) Like "#*" Then
        For Z = 1 To Len(Arr(X))
          If Mid(Arr(X), Z, 1) Like "[!0-9A-Za-z]" Then Arr(X) = Left(Arr(X), Z - 1)
        Next
        R = R + 1
        Cell.Offset(R).Value = "B" & Split(Arr(X))(0)
      End If
    Next
  Next
End Sub
Hi Rick,

That works flawlessly.

I really want to thank you for taking the time and that too multiple times in order to achieve the desired outcome. It will really make tomorrow i.e. a Monday feel like its Friday :)

Wish you a good weekend, Cheers and Thanks again.
 

Marc L

Well-known Member
Joined
Apr 5, 2021
Messages
944
Office Version
  1. 2010
Platform
  1. Windows
The RegExp way :​
VBA Code:
Sub Demo2()
            Dim Rg As Range, R&, S$()
    With CreateObject("VBScript.RegExp")
           .Global = True
           .Pattern = "B\d+\w"
        For Each Rg In [A1:B1]
            With .Execute(Rg.Text)
                If .Count Then
                    ReDim S(1 To .Count, 0)
                    For R = 1 To .Count:  S(R, 0) = .Item(R - 1).Value:  Next
                    Rg(2).Resize(.Count).Value2 = S
                End If
            End With
        Next
    End With
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,133,616
Messages
5,659,866
Members
418,535
Latest member
Ajith55

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top