This is a rather rudimentary conversion of Roman numerals into Arabic
(inverse of ROMAN function in Excel 2010)
Just copy the code and paste it into a new module. then in excel cell, type
= Arabic("xxx") where xxx is the Roman numeral (e.g. MMDX)
--
Join official Facebook page of this forum @
https://www.facebook.com/discussexcel
FORUM RULES
1) Use concise, accurate thread titles. Poor thread titles, like Please Help,
Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will not get
quick attention or may not be answered.
2) Don't post a question in the thread of another member.
3) Don't post questions regarding breaking or bypassing any security measure.
4) Acknowledge the responses you receive, good or bad.
5) Jobs posting is not allowed.
6) Sharing copyrighted material and their links is not allowed.
NOTE : Don't ever post confidential data in a workbook. Forum owners and
members are not responsible for any loss.
---
You received this message because you are subscribed to the Google Groups "MS
EXCEL AND VBA MACROS" group.
To post to this group, send email to excel-macros@googlegroups.com.
To unsubscribe from this group, send email to
excel-macros+unsubscr...@googlegroups.com.
Visit this group at http://groups.google.com/group/excel-macros?hl=en.
Option Explicit
Option Base 1
Dim strLetter(16) As String
Dim strValue As String
Const ArrayValue As String = "1, 5, 10, 50, 100, 500, 1000"
Dim blnError As Boolean
Function ARABIC(strText As String) As Integer
blnError = False
Call ReadString(UCase(strText))
If blnError = True Then
ARABIC = -1
Exit Function
End If
ARABIC = ComputeValue(strValue)
End Function
Sub ReadString(strYear As String)
Dim i As Byte
Dim byLength As Byte
byLength = Len(strYear)
If byLength > 15 Then
MsgBox "Error code 1: max number of letters is 15"
blnError = True
Exit Sub
End If
For i = 1 To byLength
strLetter(i) = Mid(strYear, i, 1)
If fCheckChar(strLetter(i)) = False Then
MsgBox "Error code 2: wrong letters used. Please use only I, V, X, L,
C, D, M letters only"
blnError = True
Exit Sub
End If
Next
Call AnalyzeString(strYear)
End Sub
Sub AnalyzeString(strYear As String)
Dim i As Byte
Dim j As Byte
Dim byLetter(16) As Byte
strValue = ""
For i = 1 To Len(strYear)
Select Case strLetter(i)
Case "I"
byLetter(i) = 1
Case "V"
byLetter(i) = 2
Case "X"
byLetter(i) = 3
Case "L"
byLetter(i) = 4
Case "C"
byLetter(i) = 5
Case "D"
byLetter(i) = 6
Case "M"
byLetter(i) = 7
End Select
strValue = strValue & CStr(byLetter(i))
Next
If j > 3 Then
For j = 1 To Len(strYear) - 3
If strLetter(j) = "I" Or strLetter(j) = "X" Or strLetter(j) = "C" Or
strLetter(j) = "M" Then
If strLetter(j) = strLetter(j + 1) And strLetter(j) = strLetter(j +
2) And strLetter(j) = strLetter(j + 3) Then
MsgBox "Error code 3a: I, X, C, M can only be repeated a
maximum of 3 times"
blnError = True
Exit Sub
End If
End If
Next
End If
If j > 1 Then
For j = 1 To Len(strYear) - 1
If strLetter(j) = "V" Or strLetter(j) = "L" Or strLetter(j) = "D" Then
If strLetter(j) = strLetter(j + 1) Then
MsgBox "Error code 3b: V, L, D can not be repeated"
blnError = True
Exit Sub
End If
End If
Next
End If
For i = 1 To Len(strYear)
If byLetter(i) < byLetter(i + 1) Then
If byLetter(i + 1) - byLetter(i) > 2 Then
MsgBox "Error code 4: wrong order of letters: check letters " & i &
" and " & i + 1
blnError = True
Exit Sub
End If
If byLetter(i) = 2 Or byLetter(i) = 4 Or byLetter(i) = 6 Then
MsgBox "Error code 5: V, L, D can never be in front of a bigger
value letter"
blnError = True
Exit Sub
End If
End If
Next
End Sub
Function fCheckChar(strLetter As String) As Boolean
fCheckChar = False
If strLetter = "I" Or strLetter = "V" Or strLetter = "X" Or strLetter = "L" Or
strLetter = "C" Or strLetter = "D" Or strLetter = "M" Then fCheckChar = True
End Function
Function ComputeValue(strValue As String) As Integer
Dim i As Byte
Dim intCode(7) As Integer
Dim k As Byte
intCode(1) = 1
intCode(2) = 5
intCode(3) = 10
intCode(4) = 50
intCode(5) = 100
intCode(6) = 500
intCode(7) = 1000
ComputeValue = 0
k = 0
If Len(strValue) = 1 Then
ComputeValue = ComputeValue + intCode(strValue)
Else
For i = 1 To Len(strValue) - 1
If Mid(strValue, i, 1) >= Mid(strValue, i + 1, 1) Then
ComputeValue = ComputeValue + intCode(Mid(strValue, i, 1))
k = 1
End If
If Mid(strValue, i, 1) < Mid(strValue, i + 1, 1) Then
ComputeValue = ComputeValue - intCode(Mid(strValue, i, 1)) +
intCode(Mid(strValue, i + 1, 1))
i = i + 1
k = 0
End If
If i = Len(strValue) - 1 Then ComputeValue = ComputeValue +
intCode(Mid(strValue, i + 1, 1))
Next
End If
End Function
