EXCELer

A Função dhRoman(123) ou, no exemplo, dhRoman(A1) retorna CXXIII:



Código:

Public Function dhRoman(ByVal intValue As Integer) As String

' Converte um numero decimal entre 1 and 3999
' em numeração romana.

' A partir de "VBA Developer's Handbook, 2nd Edition"
' por Ken Getz and Mike Gilbert
' Copyright 2001; Sybex, Inc. All rights reserved.

' Exemplo:
' dhRoman(123) retorna "CXXIII"

Dim varDigits As Variant
Dim lngPos As Integer
Dim intDigit As Integer
Dim strTemp As String

varDigits = Array("I", "V", "X", "L", "C", "D", "M")
lngPos = LBound(varDigits)
strTemp = ""
Do While intValue > 0
intDigit = intValue Mod 10
intValue = intValue \ 10
Select Case intDigit
Case 1
strTemp = varDigits(lngPos) & strTemp
Case 2
strTemp = varDigits(lngPos) & _
varDigits(lngPos) & strTemp
Case 3
strTemp = varDigits(lngPos) & _
varDigits(lngPos) & varDigits(lngPos) & strTemp
Case 4
strTemp = varDigits(lngPos) & _
varDigits(lngPos + 1) & strTemp
Case 5
strTemp = varDigits(lngPos + 1) & strTemp
Case 6
strTemp = varDigits(lngPos + 1) & _
varDigits(lngPos) & strTemp
Case 7
strTemp = varDigits(lngPos + 1) & _
varDigits(lngPos) & varDigits(lngPos) & strTemp
Case 8
strTemp = varDigits(lngPos + 1) & _
varDigits(lngPos) & varDigits(lngPos) & _
varDigits(lngPos) & strTemp
Case 9
strTemp = varDigits(lngPos) & _
varDigits(lngPos + 2) & strTemp
End Select
lngPos = lngPos + 2
Loop
dhRoman = strTemp
End Function