Extract Data Only Roman Number

[muhammad susanto]

hi all...

how to extract data contains roman number like this :

<style type="text/css">
table.tableizer-table {
font-size: 12px;
border: 1px solid #CCC ;
font-family: Arial, Helvetica, sans-serif;
}
.tableizer-table td {
padding: 4px;
margin: 3px;
border: 1px solid #CCC ;
}
.tableizer-table th {
background-color: #104E8B ;
color: #FFF ;
font-weight: bold;
}
</style>
<table class="tableizer-table">
<thead><tr class="tableizer-firstrow"><th>data</th><th>target</th></tr></thead><tbody>
<tr><td>Rumah Negara Golongan I Permanen</td><td>I</td></tr>
<tr><td>Rumah Negara Golongan II Permanen</td><td>II</td></tr>
<tr><td>Rumah Negara Golongan III Permanen</td><td>III</td></tr>
<tr><td>Rumah Negara Golongan IIA Permanen</td><td>II</td></tr>
</tbody></table>


thanks in advance..

.sst

 

[strooman]

Michael Douglas IIA Actor

You would want II returned to you; however, strooman's function returns MDII instead. Any name starting with an upper case letter that is a Roman Number "digit" letter will have that letter returned to you using strooman's code.

This is correct. You also need valid Roman numerals
We can turn the Function in a Sub and adjust it a little bit by using the Split function.

Select your cell you want to scan and run this code.

Sub extractRoman()
Dim arrItems As Variant
Dim x As Long, y As Long
Dim result As String
Dim myMatch As Object, regEx As Object

    Set regEx = CreateObject("vbscript.regexp")
    strPattern = "(M{1,4}(CM|CD|D?C{0,3})(XC|XL|L?X{0,3})(IX|IV|V?I{0,3})|M{0,4}(CM|C?D|D?C{1,3})(XC|XL|L?X{0,3})(IX|IV|V?I{0,3})|M{0,4}(CM|CD|D?C{0,3})(XC|X?L|L?X{1,3})(IX|IV|V?I{0,3})|M{0,4}(CM|CD|D?C{0,3})(XC|XL|L?X{0,3})(IX|I?V|V?I{1,3}))"
    
    strInputText = Selection
    With regEx
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = strPattern
    End With
    
    Set myMatch = regEx.Execute(strInputText)
    
    For x = 0 To myMatch.Count - 1
            result = result & myMatch.Item(x) & ","
    Next
    arrItems = Split(Mid(result, 1), ",")
    Selection.Offset(0, 1).Resize(1, UBound(arrItems)) = arrItems
End Sub

Row\Col	A​	B​	C​	D​	E​	F​
1​	Your_Line	First	Second	Third	Fourth	Fifth
2​	Rumah Negara Golongan I Permanen	I
3​	Rumah Negara Golongan II Permanen	II
4​	Of the letters used CCLIII commonly in Roman numerals	CCLIII
5​	Rumah Negara Golongan IIA Permanen	II
6​	Super Bowl XXX.	XXX
7​	Years in Roman numerals: a.d. MCMLXXXIX = a.d. 1989.	MCMLXXXIX
8​	This is the number 13, XIII	XIII
9​	We live in the year 2018 wich is MMXVIII	MMXVIII
10​	MCMXCIX	MCMXCIX
11​	Combination of MMXVIII and CMA	C	MMXVIII	C	M
12​	Michael Douglas IIA Actor	M	D	II

 

[Rick Rothstein]

Assuming that the non-Roman Number text is either in all lower case or in proper case, here is a macro that I believe will return only real Roman Numbers as long as that Roman Number begins the text or is preceded by a space character...

[table="width: 500"]
[tr]
	[td]Sub ExtractRomanNumbers()
  Dim R As Long, X As Long, C As Long, Z As Long, LastRow As Long, MaxWordCount As Long
  Dim Arr As Variant, Data As Variant, Result As Variant
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  MaxWordCount = Evaluate(Replace("1+MAX(LEN(A2:A#)-LEN(SUBSTITUTE(A2:A#,"" "","""")))", "#", LastRow))
  Data = Range("A2:A" & LastRow)
  ReDim Result(1 To UBound(Data), 1 To MaxWordCount)
  For R = 1 To UBound(Data)
    Arr = Split(Data(R, 1))
    C = 0
    For X = 0 To UBound(Arr)
      If Arr(X) Like "[IVXLCMD]*" Then
        If Mid(Arr(X) & " ", 2, 1) Like "[IVXLCMD ]" Then
          C = C + 1
          For Z = 2 To Len(Arr(X)) + 1
            If Mid(Arr(X) & " ", Z, 1) Like "[!IVXLCMD]" Then
              Result(R, C) = Left(Arr(X), Z - 1)
              Exit For
            End If
          Next
        End If
      End If
    Next
  Next
  Range("B2").Resize(UBound(Result, 1), UBound(Result, 2)) = Result
End Sub[/td]
[/tr]
[/table]

 

[Rick Rothstein]

As a follow up to the code I posted in Message #22 above, I modified the code to remove the restriction that the Roman Numbers had to be preceded by a space character (when it did not start the text). This will allow the Roman Number to be preceded by or followed by parentheses, brackets, braces, quote marks, dashes, etc. I think I have caught all of the problem areas, but if you come across one, please let me know so I can try to fix the macro for it.

[table="width: 500"]
[tr]
	[td]Sub ExtractRomanNumbers()
  Dim R As Long, X As Long, C As Long, Z As Long, LastRow As Long, MaxWordCount As Long
  Dim Arr As Variant, Data As Variant, Result As Variant
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  MaxWordCount = Evaluate(Replace("1+MAX(LEN(A2:A#)-LEN(SUBSTITUTE(A2:A#,"" "","""")))", "#", LastRow))
  Data = Range("A2:A" & LastRow)
  ReDim Result(1 To UBound(Data), 1 To MaxWordCount)
  For R = 1 To UBound(Data)
    For X = 1 To Len(Data(R, 1))
      If Mid(Data(R, 1) & " ", X, 1) Like "[!IVXLCMD]" Or Mid(Data(R, 1), X + 1, 1) Like "[a-z]" Then
        Mid(Data(R, 1), X) = " "
      End If
    Next
    Arr = Split(Application.Trim(Data(R, 1)))
    C = 0
    For X = 0 To UBound(Arr)
      C = C + 1
      Result(R, C) = Arr(X)
    Next
  Next
  Range("B2").Resize(UBound(Result, 1), UBound(Result, 2)) = Result
End Sub[/td]
[/tr]
[/table]

 

[strooman]

Very thorough solution Rick. You gave it a good try to come up with something so robust. Definitly come in handy.