EXCEL2010で使用できるように自作
Option Explicit
Function ARABIC(ByVal Data As String) As Long 'ARABIC関数（EXCEL2010で使用できるように自作）
Dim Minus As Integer
Dim D() As String
Dim i As Integer
Data = Replace(UCase(StrConv(Data, vbNarrow)), " ", "")
If Left$(Data, 1) = "-" Then
Minus = 1
Data = Right$(Data, Len(Data) - 1)
End If
If Len(Data) > 255 Then
ARABIC = CVErr(xlErrValue)
Exit Function
End If
If Data = "" Then
ARABIC = 0
Exit Function
End If
For i = 1 To Len(Data)
Select Case Mid$(Data, i, 1)
Case "C"
Case "D"
Case "I"
Case "L"
Case "M"
Case "V"
Case "X"
Case Else
ARABIC = CVErr(xlErrValue)
Exit Function
End Select
Next i
ReDim D(Len(Data) + 1)
For i = 1 To Len(Data)
D(i) = Mid$(Data, i, 1)
Next i
i = 1
Do
If D(i) = "M" Then
ARABIC = ARABIC + 1000
i = i + 1
End If
Loop While D(i) = "M"
If i > Len(Data) Then
GoTo EndFunction
End If
If D(i) = "C" Then
If D(i + 1) = "M" Then
ARABIC = ARABIC + 900
i = i + 2
ElseIf D(i + 1) = "D" Then
ARABIC = ARABIC + 400
i = i + 2
ElseIf D(i + 1) = "C" Then
If D(i + 2) = "C" Then
ARABIC = ARABIC + 300
i = i + 3
Else
ARABIC = ARABIC + 200
i = i + 2
End If
Else
ARABIC = ARABIC + 100
i = i + 1
End If
End If
If i > Len(Data) Then
GoTo EndFunction
End If
If D(i) = "D" Then
If D(i + 1) = "C" Then
If D(i + 2) = "C" Then
If D(i
+ 3) = "C" Then
ARABIC =
ARABIC + 800
i = i +
4
Else
ARABIC =
ARABIC + 700
i = i +
3
End
If
Else
ARABIC = ARABIC + 600
i = i + 2
End If
Else
ARABIC = ARABIC + 500
i = i + 1
End If
End If
If i > Len(Data) Then
GoTo EndFunction
End If
'ROMAN(数値,1)対応
If D(i) = "L" Then
If D(i + 1) = "M" Then
ARABIC = ARABIC + 950
i = i + 2
ElseIf D(i + 1) = "D" Then
ARABIC = ARABIC + 450
i = i + 2
End If
End If
If i > Len(Data) Then
GoTo EndFunction
End If
'ROMAN(数値,2)対応
If D(i) = "X" Then
If D(i + 1) = "M" Then
ARABIC = ARABIC + 990
i = i + 2
ElseIf D(i + 1) = "D" Then
ARABIC = ARABIC + 490
i = i + 2
End If
End If
If i > Len(Data) Then
GoTo EndFunction
End If
'ROMAN(数値,3)対応
If D(i) = "V" Then
If D(i + 1) = "M" Then
ARABIC = ARABIC + 995
i = i + 2
ElseIf D(i + 1) = "D" Then
ARABIC = ARABIC + 495
i = i + 2
End If
End If
If i > Len(Data) Then
GoTo EndFunction
End If
'ROMAN(数値,4)対応
If D(i) = "I" Then
If D(i + 1) = "M" Then
ARABIC = ARABIC + 999
i = i + 2
ElseIf D(i + 1) = "D" Then
ARABIC = ARABIC + 499
i = i + 2
End If
End If
If i > Len(Data) Then
GoTo EndFunction
End If
If D(i) = "X" Then
If D(i + 1) = "C" Then
ARABIC = ARABIC + 90
i = i + 2
ElseIf D(i + 1) = "L" Then
ARABIC = ARABIC + 40
i = i + 2
ElseIf D(i + 1) = "X" Then
If D(i + 2) = "X" Then
ARABIC = ARABIC + 30
i = i + 3
Else
ARABIC = ARABIC + 20
i = i + 2
End If
Else
ARABIC = ARABIC + 10
i = i + 1
End If
End If
If i > Len(Data) Then
GoTo EndFunction
End If
If D(i) = "L" Then
If D(i + 1) = "X" Then
If D(i + 2) = "X" Then
If D(i
+ 3) = "X" Then
ARABIC =
ARABIC + 80
i = i +
4
Else
ARABIC =
ARABIC + 70
i = i +
3
End
If
Else
ARABIC = ARABIC + 60
i = i + 2
End If
Else
ARABIC = ARABIC + 50
i = i + 1
End If
End If
If i > Len(Data) Then
GoTo EndFunction
End If
'ROMAN(数値,1)対応
If D(i) = "V" Then
If D(i + 1) = "C" Then
ARABIC = ARABIC + 95
i = i + 2
ElseIf D(i + 1) = "L" Then
ARABIC = ARABIC + 45
i = i + 2
End If
End If
If i > Len(Data) Then
GoTo EndFunction
End If
'ROMAN(数値,2)対応
If D(i) = "I" Then
If D(i + 1) = "C" Then
ARABIC = ARABIC + 99
i = i + 2
ElseIf D(i + 1) = "L" Then
ARABIC = ARABIC + 49
i = i + 2
End If
End If
If i > Len(Data) Then
GoTo EndFunction
End If
If D(i) = "I" Then
If D(i + 1) = "X" Then
ARABIC = ARABIC + 9
i = i + 2
ElseIf D(i + 1) = "V" Then
ARABIC = ARABIC + 4
i = i + 2
ElseIf D(i + 1) = "I" Then
If D(i + 2) = "I" Then
ARABIC = ARABIC + 3
i = i + 3
Else
ARABIC = ARABIC + 2
i = i + 2
End If
Else
ARABIC = ARABIC + 1
i = i + 1
End If
End If
If i > Len(Data) Then
GoTo EndFunction
End If
If D(i) = "V" Then
If D(i + 1) = "I" Then
If D(i + 2) = "I" Then
If D(i
+ 3) = "I" Then
ARABIC =
ARABIC + 8
i = i +
4
Else
ARABIC =
ARABIC + 7
i = i +
3
End
If
Else
ARABIC = ARABIC + 6
i = i + 2
End If
Else
ARABIC = ARABIC + 5
i = i + 1
End If
End If
EndFunction:
If Minus = 1 Then
ARABIC = 0 - ARABIC
End If
End Function
以上。
