学以致用-Excel Arabic函数（将阿拉伯数字转换为罗马数字）的VBA实现

看到的资料中使用了罗马字序号（XVI），比较好奇这个序号对应的阿拉伯数字是多少。

于是，百度了一下，学到了两个新的Excel函数：ROMAN()和ARABIC()，可以实现罗马数字（I, II, III ...）与阿拉伯数字（1, 2, 3, ...）的相互转换。

问题是，在我的Excel 2016中，ARABIC函数似乎不存在（出现了#NAME#错误）。

所以，让我们来使用VBA实现一个类似于ARABIC函数功能吧。

运行这段代码，在输入框中输入要转换的罗马字，即可得到对应的阿拉伯数字。



源码如下：

Sub ArabicFunction()
'
' Convert a Roman number to Arabic number (from 1 to 3999)
'

'
Application.ScreenUpdating = False

ActiveSheet.Select
Range("A1").Value = 1
Range("A1").Select
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
Step:=1, Stop:=3999, Trend:=False
Range("B1").Select
ActiveCell.FormulaR1C1 = "=ROMAN(RC[-1])"
Range("B1").Select
Selection.AutoFill Destination:=Range("B1:B3999")
Range("B1:B3999").Select
Range("B1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Range("D1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("C1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="vl_arabic", RefersToR1C1:= _
"=R1C3:R3999C4"
ActiveWindow.SmallScroll Down:=-9
Range("F1").Select
ActiveCell.FormulaR1C1 = "Roman"
Range("F1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5296274
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("F2").Select
ActiveCell.FormulaR1C1 = "Arabic"
Range("F2").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
Range("F2").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("G1").Select
ActiveCell.FormulaR1C1 = "V"
Range("G2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(R[-1]C,vl_arabic,1,FALSE)"
Range("G2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(R[-1]C,vl_arabic,2,FALSE)"
Range("G2").Select

Application.ScreenUpdating = True
End Sub