Help with a formula to extract all 8 character alpha-numeric IDs from an Excel column

[techie2]

I am new to this forum. I have seen some excellent suggestions and solutions being posted.

I have a spread sheet with Special Notes column which has notes text in each cell of the column. Each cell text contains one or more 8 character numeric and alpha numeric IDs. I need to extract all these IDs and dump them in a separate column on the spread sheet . I am giving examples of text from two cells in the column:

K1= Model Z behind model 8 (ABC Company) Please generate AMC 47052130 (replacing dialup AMC 47059003)
K2= Model J behind model 9 (XYZ Company) Please Generate AMC ID 4554G023 (replacing 4554A032)

Is there a formula I can use to extract those 8 character AMC IDs with or without AMC in front of them.

I am very excited to be on this forum.

Thanks in advance

Techie

 

[Rick Rothstein]

Rick,

My code was built for extracting numbers from selected data in form of:
1. Integers (treating as millimeters)
2. Decimals (treating as millimeters)
3. Inches expressions (integer or fractional)

The identification code before each number: ID = "ID", OD = "OD", W = "W", W1 = "SECT" (modification of W)
Between code and number there can (or can't) be some symbols: [:;, ]

The result is in the 6 next columns to the right: 3 columns are for Millimeters and 3 columns - for Inches.
See more details in my post #43.
Some testing data and the result

Book1
	A	B	C	D	E	F	G
1	Specification	ID mm	OD mm	W mm	ID "	OD "	W "
2	6203-2RS: BRG; Deep groove ball bearing; ID: 17mm, OD40mm, W, 12mm, (2) rubber seals, std clearance	17	40	12	2/3''	1-4/7''	1/2''
3	; WOOD ; ... ; ID: 17mm, OD40mm, W, 12mm, (2)	17	40	12	2/3''	1-4/7''	1/2''
4	EG - Oil Seal; 22527537TC; Imperial, NBR, Double lip, rubber encased, ID:2-1/4" OD:2-3/4" W:3/8"	57.15	69.85	9.53	2-1/4''	2-3/4''	3/8''
5	BS 255 PACK5 VITON O-Ring; BS255V-PACK5; Imperial BS, Viton, Nominal ID:5-5/8" OD:5-7/8" SECT:1/8", Pack 5 142.88 5-5/8'' 149.23 5-7/8''	142.88	149.23	3.18	5-5/8''	5-7/8''	1/8''
6	BS 256 O-Ring; BS256; Imperial BS, Nitrile, Nominal ID:5-3/4" OD:6" SECT:1/8" 146.05 5-3/4'' 6.00 1/4''	146.05	152.40	3.18	5-3/4''	6 ''	1/8''
Sheet1

Thank you for the examples (I am visually-oriented and can "see" the code that needs to be written better when I can see the data as opposed to trying to figure the data out from a verbal description). Here is the macro I came up with... the two macros, for all practical purposes, take the same amount of time to execute (18,000 rows of data... your macro took, on average, 0.1375 seconds to complete, my macro took, on average, 0.125 seconds to complete)...

[table="width: 500"]
[tr]
	[td]Sub Extract_ID_OD_W()
  Dim X As Long, Z As Long, R As Long, Col As Long, Idx As Long, Temp As Double, Cell As Range
  Dim ID As String, OD As String, W As String, S As String, Parts() As String, Nums() As String
  Dim Data As Variant, Result() As Variant
  On Error Resume Next
  Data = Selection
  ReDim Result(1 To UBound(Data), 1 To 6)
  For R = 1 To UBound(Data)
    S = Replace(Replace(Replace(Replace(UCase(Data(R, 1)), "ID", "ID "), "OD", "OD "), "W", "W "), "SECT", "SECT ")
    For X = 1 To Len(S)
      If Not Mid(S, X, 1) Like "[ IODWSECTM""0-9/.-]" Then Mid(S, X) = " "
    Next
    Parts = Split(Application.Trim(S))
    For X = 0 To UBound(Parts)
      Col = InStr(" ID OD W  SECT ", " " & Parts(X) & " ")
      If Col > 0 Then
        Idx = Application.Min(3, 1 + (Col - 1) / 3)
        If Right(Parts(X + 1), 1) = "M" Then
          Result(R, Idx) = Val(Parts(X + 1))
          Result(R, Idx + 3) = Result(R, Idx) / 25.4
        Else
          Nums = Split(Replace(Replace(Parts(X + 1), "-", "/"), """", ""), "/")
          If UBound(Nums) = 2 Then
            Result(R, Idx + 3) = Nums(0) + Nums(1) / Nums(2) 'Evaluate(Replace(Replace(Parts(X + 1), """", ""), "-", " "))
          ElseIf UBound(Nums) = 1 Then
            Result(R, Idx + 3) = Nums(0) / Nums(1)
          Else
            Result(R, Idx + 3) = Nums(0)
          End If
          Result(R, Idx) = 25.4 * Result(R, Idx + 3)
        End If
      End If
    Next
  Next
  Selection(1).Offset(, 1).Resize(UBound(Result), 6) = Result
  Selection(1).Offset(, 4).Resize(UBound(Result), 3).NumberFormat = "#-?/?\"""
  On Error GoTo 0
End Sub[/td]
[/tr]
[/table]

 

[AndrewP70]

Hi Ziv and Rick,
The Ecat which I have spent several years collating is extremely diverse in its product range and as such is very difficult to standardise a long description to enable the extraction of data.
Eg Most bearings (here in lies another problem for later) can be classified by ID, OD and Width. Already as the O'Ring example showed, the industry standard for these is not Width but SECT (section). Simply terminology and as such the W value can be easily filtered and a new column SECT created. The product file is broken down into major groups. Eg Seals, Sleeves, Sprockets etc. There are over 170 major groups and 125,000 items. Some groups can easily be formatted by filters alone. Eg sprockets, "begins with 06, 08 etc. The number of teeth "mid" part number etc. The end result I am working towards is a set of identifiers that are the industry standard for the major group.
Eg Sprockets do not use ID, OD, W. Instead the values to be returned would be "Standard" BS or ANSI, No of teeth, No of rows (simplex, duplex etc).
I hope this makes sense and I cannot express my gratitude enough for the help I have received. No doubt there will be some curly requests for other major groups.
Thanks and Best regards,
Andrew.

 

[AndrewP70]

Hi Ziv, this might be the last complex extraction I require.

Long Text examples.
BRG; Taper Roller Bearing, 00000 Series Single Cone; 1/2" Straight Bore; 0.5540" Wide; 0.060" Maximum Shaft Fillet Radius; Standard Tolerance
BRG; Taper Roller Bearing, Series 00000 Single Cup; 1 1/2" OD x 7/16" Wide; 0.030" Maximum Housing Fillet Radius; Standard Tolerance
BRG; Taper Roller Bearing, Series 00000 Single Cup; 1 1/2" OD x 0.5337" Wide; 0.030" Maximum Housing Fillet Radius; Standard Tolerance
BRG; Taper Roller Bearing,, Series 02400 Single Cup; 2.637" OD x 0.6299" Wide; 0.060" Maximum Housing Fillet Radius; Standard Tolerance
BRG; Taper Roller Bearing, Series 02400 Single Cup; 2 11/16" OD x 11/16" Wide; 0.060" Maximum Housing Fillet Radius; Standard Tolerance
BRG; Taper Roller Bearing, 02400 Series Single Cone; 1" Straight Bore; 7/8" Wide; 0.030" Maximum Shaft Fillet Radius; Standard Tolerance
BRG; Taper Roller Bearing, 02400 Series Single Cone; 1.1019" Straight Bore; 0.8070" Wide; 0.030" Maximum Shaft Fillet Radius; Standard Tolerance; w/Keyway Slot

Where the following is required.
Find Cup or Cone and return to Column C
Where "Cone" return dimension immediately before "Straight Bore" to column D
Where "Cone" return dimension immediately before the word "Wide" and after "Straight Bore" to column E
Where "Cone" return dimension immediately before the words" Maximum Shaft" and before the word "Wide" to column F
Where "Cup" return dimension immediately before "OD" and after the word "Cup" and return to column G
Where "Cup" return the dimension immediately before the word "Wide" and return to column H
Where "Cup" return the dimension immediately before the words "Maximum Housing and before the word "Wide" to column I

As usual Many Many thanks
Andrew

 

[ZVI]

Try this:

Sub ExtractDimensions6()
  ' ZVI:2016-03-04 http://www.mrexcel.com/forum/excel-questions/706471-help-formula-extract-all-8-character-alpha-numeric-ids-excel-column.html
  ' Select the source range and run this macro,
  ' Result: 3 columns in Millimeters + 3 columns in Inches
 
  ' --> Dimensions, change to suit
  Const D1 = "ID,Cone,Cup"
  Const D2 = "OD,Bore"
  Const D3 = "W,SECT,Wide"
  ' <--
 
  Dim a, b(), ID, OD, W, v
  Dim c As Long, i As Long, j As Long, k As Long, r As Long
  Dim s As String, s1 As String
  Dim Rng As Range
 
  ' Arrays of the dimensions
  ID = Split(D1, ",")
  OD = Split(D2, ",")
  W = Split(D3, ",")
 
  ' Limit selection by the used range to allow selection of the full column
  Set Rng = Intersect(Selection, ActiveSheet.UsedRange)
  If Rng Is Nothing Then Exit Sub
 
  ' Copy values of the selected cells to the array a()
  With Rng
    a = .Value
    If Not IsArray(a) Then
      ReDim a(1 To 1, 1 To 1)
      a(1, 1) = .Value
    End If
  End With
 
  ' Prepare the output array b()
  ReDim b(1 To UBound(a), 1 To 6)
 
  ' Main
  With CreateObject("vbscript.regexp")
    .Global = True
    s = "((" & ID(0) & ")|(" & OD(0) & ")|(" & W(0) & "))"  ' Code
    s = s & "([:;.,x\s]?)+"                                 ' Symbols
    s = s & "((\d+([.\-\s]\d+)?(\/\d+)?\"")|(\d+(\.\d+)?))" ' Inches or Numbers
    .Pattern = s
    i = UBound(b, 2)
    For r = 1 To UBound(a, 1)
      If Len(a(r, 1)) Then
        s = a(r, 1)
        For k = 1 To UBound(ID)
          s = Replace(s, ID(k), ID(0), Compare:=vbTextCompare)
        Next
        For k = 1 To UBound(OD)
          s = Replace(s, OD(k), OD(0), Compare:=vbTextCompare)
        Next
        For k = 1 To UBound(W)
          s = Replace(s, W(k), W(0), Compare:=vbTextCompare)
        Next
        With .Execute(s)
          j = .Count
          If j > i Then j = i
          For k = 1 To j
            Select Case .Item(k - 1).SubMatches(0)
              Case ID(0): c = 1
              Case OD(0): c = 2
              Case W(0):  c = 3
            End Select
            s = .Item(k - 1).SubMatches(5)
            If Right$(s, 1) = Chr$(34) Then
              b(r, c + 3) = Replace(s, " ", "-")
              ' Convert Inches to Millimeters
              s = Left$(s, Len(s) - 1)
              s = Replace(s, "-", "+")
              s = Replace(s, " ", "+")
              s = "=(" & s & ")*25.4"
              b(r, c) = s 'Evaluate(s)
            Else
              v = Val(s)
              Select Case v
                Case Is < 0.254: s1 = "???/???"
                Case Is < 2.54: s1 = "??/??"
                Case Else: s1 = "?/?"
              End Select
              b(r, c) = s
              s = "=SUBSTITUTE(TEXT(" & Str(v) & "/25.4,""#""""-""""" & s1 & """),"" "","""")&"""""""""
              b(r, c + 3) = s
            End If
          Next
        End With
      End If
    Next
  End With
 
  ' Put the result in Millimeters & Inches into 6 next columns
  With Rng.Offset(, 1).Resize(, 6)
    .NumberFormat = "0.00"
    .Value = b()
    .Value = .Value ' Comment this line to see the formulas
  End With
 
End Sub

The result:

Book1
	A	B	C	D	E	F	G
1	Specification	ID mm	OD mm	W mm	ID "	OD "	W "
2	6203-2RS: BRG; Deep groove ball bearing; ID: 17mm, OD40mm, W, 12mm, (2) rubber seals, std clearance	17.00	40.00	12.00	2/3"	1-4/7"	1/2"
3	; WOOD ; ... ; ID: 17mm, OD40mm, W, 12mm, (2)	17.00	40.00	12.00	2/3"	1-4/7"	1/2"
4	EG - Oil Seal; 22527537TC; Imperial, NBR, Double lip, rubber encased, ID:2-1/4" OD:2-3/4" W:3/8"	57.15	69.85	9.53	2-1/4"	2-3/4"	3/8"
5	BS 255 PACK5 VITON O-Ring; BS255V-PACK5; Imperial BS, Viton, Nominal ID:5-5/8" OD:5-7/8" SECT:1/8", Pack 5 142.88 5-5/8'' 149.23 5-7/8''	142.88	149.23	3.18	5-5/8"	5-7/8"	1/8"
6	BS 256 O-Ring; BS256; Imperial BS, Nitrile, Nominal ID:5-3/4" OD:6" SECT:1/8" 146.05 5-3/4'' 6.00 1/4''	146.05	152.40	3.18	5-3/4"	6"	1/8"
7
8	BRG; Taper Roller Bearing, 00000 Series Single Cone; 1/2" Straight Bore; 0.5540" Wide; 0.060" Maximum Shaft Fillet Radius; Standard Tolerance	12.70	14.07	1.52	1/2"	0.5540"	0.060"
9	BRG; Taper Roller Bearing, Series 00000 Single Cup; 1 1/2" OD x 7/16" Wide; 0.030" Maximum Housing Fillet Radius; Standard Tolerance	38.10	11.11	0.76	1-1/2"	7/16"	0.030"
10	BRG; Taper Roller Bearing, Series 00000 Single Cup; 1 1/2" OD x 0.5337" Wide; 0.030" Maximum Housing Fillet Radius; Standard Tolerance	38.10	13.56	0.76	1-1/2"	0.5337"	0.030"
11	BRG; Taper Roller Bearing,, Series 02400 Single Cup; 2.637" OD x 0.6299" Wide; 0.060" Maximum Housing Fillet Radius; Standard Tolerance	66.98	16.00	1.52	2.637"	0.6299"	0.060"
12	BRG; Taper Roller Bearing, Series 02400 Single Cup; 2 11/16" OD x 11/16" Wide; 0.060" Maximum Housing Fillet Radius; Standard Tolerance	68.26	17.46	1.52	2-11/16"	11/16"	0.060"
13	BRG; Taper Roller Bearing, 02400 Series Single Cone; 1" Straight Bore; 7/8" Wide; 0.030" Maximum Shaft Fillet Radius; Standard Tolerance	25.40	22.23	0.76	1"	7/8"	0.030"
14	BRG; Taper Roller Bearing, 02400 Series Single Cone; 1.1019" Straight Bore; 0.8070" Wide; 0.030" Maximum Shaft Fillet Radius; Standard Tolerance; w/Keyway Slot	27.99	20.50	0.76	1.1019"	0.8070"	0.030"
Sheet1

 

[AndrewP70]

Hello Ziv, Hope you are well. Is there anyway I can return multiple values into separate columns via vlookup?
Re the below. Find Item 68X88X9TC and return the alt values into 4 separate columns.
Once again many Thanks
Item Alt Ref.
68X88X9TC TC12647
68X88X9TC PR8359
68X88X9TC PR8410
68X88X9TC X3885

 

[ZVI]

Hello Ziv, Hope you are well. Is there anyway I can return multiple values into separate columns via vlookup?
Re the below. Find Item 68X88X9TC and return the alt values into 4 separate columns.
Once again many Thanks
Item Alt Ref.
68X88X9TC TC12647
68X88X9TC PR8359
68X88X9TC PR8410
68X88X9TC X3885

Hi Andrew,

I'm well, thanks, and hope you are as well

Your new task looks absolutely different to this thread thematic.
Will creating of new thread be more suitable for such a case?
PM me the link if you've already created new thread, if not then we can continue here, of course.

Comments about "formula" solution you have highlighted.
1. Excel's VLOOKUP function can't return multiple values, but its VBA alternative can do that of course.
2. Only array formula which is entered into some cells can return separate values into those cells.
And as it's previously unknown how many values are expected in result, that array formula should be entered into array of cells with some extra/reserved columns.

VBA alternative behavior can be:
1. UDF which is entered as array formula into selected cells in a row via Ctrl-Shift-Enter with some extra selected columns as we don't know how many columns are required for the result.
2. Macro which is called as usual, for example, by Alt-F8 or via button linked to that macro. You have to define in this macro the 1st cell of destination range.

Please select the suitable behavior and post more details about your cells layout.

Regards,

 

[AndrewP70]

Hi Ziv
My apologies here. I am so confused with posts , threads PM
Return multiple values into seperate columns via vlookup?
I created this only this morning.

Many Thanks

 

[ZVI]

Still not sure if this thread is good for publication but here is example of VBA solution:

Function Lookups(Lookup_Value, ByVal Table_Array As Range, Col_Index_Num As Long)
' ZVI:2016-05-31 http://www.mrexcel.com/forum/excel-questions/706471-help-formula-extract-all-8-character-alpha-numeric-ids-excel-column-2.html#post4537576
 
  Dim a(), b(), v
  Dim i As Long, j As Long, k As Long
  Dim s As String
  Dim IsString As Boolean
 
  ' Limit data by used range to allow full columns referense without slowing the code
  Set Table_Array = Intersect(Table_Array, Table_Array.Worksheet.UsedRange)
  IsString = VarType(Lookup_Value) = vbSingle
 
  ' Copy data to arrays to speed up the code
  With Table_Array
    a() = .Columns(1).Value
    b() = .Columns(Col_Index_Num).Value
  End With
 
  ' Main
  With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a)
      If IsString Then
        If StrComp(a(i, 1), Lookup_Value, vbTextCompare) = 0 Then .Item(b(i, 1)) = vbNullString
      Else
        If a(i, 1) = Lookup_Value Then .Item(b(i, 1)) = vbNullString
      End If
    Next
    j = .Count
    If j Then
      ' Found - put result in v()
      v = .Keys
      ' Replace #N/A in extra columns of the UDF's destination cells by vbNullString
      With Application
        If TypeName(.Caller) = "Range" Then
          ' UDF is called from cells
          k = .Caller.Columns.Count
          If k > j Then
            ReDim Preserve v(k - 1)
            For i = j To k - 1
              v(i) = vbNullString
            Next
          End If
        End If
      End With
    Else
      ' Not found - return vbNullString instead of #N/A
      v = Array(vbNullString)
    End If
  End With
 
  ' Return
  Lookups = v
 
End Function

How to use it as UDF in cells:

Book1
	A	B	C	D	E	F	G	H	I	J	K
1	Item	Alt Ref.		Lookup_Value	Cells of array formula
2	68X88X9T	aaa		68X88X9TC	TC12647	PR8359	PR8410	X3885
3	68X88X9TC	TC12647		Select E2:J2, put formula =Lookups(D2,A:B,2) and confirm it by Ctrl-Shift-Enter
4	68X88X9TC	PR8359
5	68X88X9TC	PR8410		68X88X9T	aaa	bbb	ccc
6	68X88X9T	bbb		Select E5:J5, put formula =Lookups(D5,A:B,2) and confirm it by Ctrl-Shift-Enter
7	68X88X9TC	X3885
8	68X88X9T	ccc		ABCD
9				Select E8:J8, put formula =Lookups(D8,A:B,2) and confirm it by Ctrl-Shift-Enter
Sheet1

<br />

And how to call Vlooups function via macro with putting the result into cells:

Sub How_To_Call_Vlookups_in_VBA()
  Dim a
  a = Lookups("68X88X9TC", Range("A:B"), 2)
  Range("E11").Resize(, UBound(a) + 1).Value = a
End Sub

 

[ZVI]

Hi Ziv
My apologies here. I am so confused with posts , threads PM
Return multiple values into seperate columns via vlookup?
I created this only this morning.

Many Thanks

It's Ok, I've reposted Vlookups VBA solution in your new thread