تبدیل کلمات به اعداد

Question

گیب قبلا از ماکروها برای تبدیل اعداد (مانند 355) به کلمات (سیصد و پنجاه و پنج) استفاده کرده است. اگر یک ماکرو داشته باشد که بتواند برعکس عمل کند و کلماتی را که انتخاب می کند دوباره به اعداد تبدیل کند، بسیار مفید خواهد بود. با این حال، او مطمئن نیست که چگونه چنین ماکرو ایجاد کند.

یک ماکرو برای مدیریت این نوع تبدیل بیشتر از آنچه که انتظار می رود درگیر است، اما می توان با محدود کردن ماکرو به گونه ای که فقط اعداد کامل را کنترل کند، کمی ساده تر می شود. دو ماکرو زیر (یکی زیربرنامه و دیگری تابعی است که از زیربرنامه فراخوانی می شود) هر متن انتخاب شده را تا 999,999,999 تبدیل می کند.

Sub TextToNumbers()
    Dim NText() As Variant
    Dim NB() As Variant
    Dim aRange As Range
    Dim k As Long
    Dim L As Long
    Dim LL As Long
    Dim LLL As Long
    Dim s As String
    Dim j As Long
    Dim m As Long
    Dim mm As Long
    Dim mmm As Long
    Dim gA() As Long
    Dim gB() As Long
    Dim wCount As Long
    Dim ThousandsComma As Boolean

    ThousandsComma = True  " --- gives thousands commas ----

    NText = Array("AND", "-", "ONE", "TWO", "THREE", "FOUR", "FIVE", _
      "SIX", "SEVEN", "EIGHT", "NINE", "TEN", "ELEVEN", "TWELVE", "THIRTEEN", _
      "FOURTEEN", "FIFTEEN", "SIXTEEN", "SEVENTEEN", "EIGHTEEN", "NINETEEN", _
      "TWENTY", "THIRTY", "FORTY", "FIFTY", "SIXTY", "SEVENTY", "EIGHTY", _
      "NINETY", "HUNDRED", "THOUSAND", "MILLION", "$%$%")

    NB = Array(0, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, _
      11, 12, 13, 14, 15, 16, 17, 18, 19, _
      20, 30, 40, 50, 60, 70, 80, 90, _
      100, 1000, 1000000, 0)

    " ------ Check selected text for validity ---------------
    Set aRange = Selection.Range
    If Right(aRange.Text, 1) = Chr(13) Then
        aRange.MoveEnd Unit:=wdCharacter, Count:=-1
    End If
    s = aRange.Text
    If Right(s, 1) = "." Then aRange.MoveEnd Unit:=wdCharacter, Count:=-1
    If aRange.Paragraphs.Count > 1 Then
        MsgBox "Selection cannot span paragraphs"
        Exit Sub
    End If
    If Trim(aRange.Text) = "" Then
        MsgBox "Selection does not include a word"
        Exit Sub
    End If
    " ------------------------------

    wCount = aRange.Words.Count
    ReDim gA(wCount + 1)
    ReDim gB(wCount + 1)

    For k = 1 To wCount   " aRange.Words.Count
        s = UCase(Trim(aRange.Words(k)))
        If s = Chr(13) Or s = "" Then
            gB(k) = 1
            gA(k) = 0
            GoTo FF2
        End If
        For m = 0 To UBound(NText) - 1
            If s = NText(m) Then GoTo FF1
        Next m
        MsgBox "The word " & """" & aRange.Words(k) & """" & " is non numeric"
        Exit Sub
FF1:
        gA(k) = NB(m)
        If m > UBound(NText) - 5 Then
            gB(k) = 2
        Else
            gB(k) = 1
        End If
FF2:
    Next k
   " Arrays gA & gB hold word values and the operator on that word

    wCount = removeZeros(gA(), gB(), wCount)

    " ----- combine multiple numbers and remove zero entries -----
    For k = 1 To wCount - 1
        If gB(k) = 1 And gB(k + 1) = 1 Then
            gA(k + 1) = gA(k + 1) + gA(k)
            gA(k) = 0
        End If
    Next k
    wCount = removeZeros(gA(), gB(), wCount)

    m = 1
    Do
        m = m + 1
    Loop Until m > wCount Or gA(m) = 1000000
    If m <= wCount Then " 1000000 is at gA(m)
        " check that there are no 1000s
        j = 1
        Do
            j = j + 1
        Loop Until j >= m Or gA(j) = 1000
        If j < m Then
            MsgBox "Cannot process thousands of millions"
            Exit Sub
        End If

        j = 1
        Do
            j = j + 1
        Loop Until j >= m Or gA(j) = 100
        If j < m Then
            gA(j) = gA(j) * gA(j - 1)
            gA(j - 1) = 0
            gB(j) = 1
        End If
        LL = 0
        For j = 1 To m - 1
            L = L + gA(j)
            gA(j) = 0
            gB(j) = 0
        Next j
        gA(m) = L * gA(m)
        gB(m) = 1
    Else
        m = 0
    End If " 1000000 processed

    mm = j + 1
    If mm  wCount Or gA(mm) = 1000
    End If
    If mm <= wCount Then " 1000 is at ga(mm)
        j = m + 1
        Do
            j = j + 1
        Loop Until j >= mm Or gA(j) = 100
        If j < mm Then " have 100 preceeding 1000
            gA(j) = gA(j) * gA(j - 1)
            gA(j - 1) = 0
            gB(j) = 1
        End If
        LL = 0
        For j = m + 1 To mm - 1
            LL = LL + gA(j)
            gA(j) = 0
            gB(j) = 1
        Next j
        gA(mm) = LL * gA(mm)
        gB(mm) = 1
    Else
        mm = m
    End If " 1000 is at mmth entry

    mmm = mm + 1
    If mmm  wCount Or gA(mmm) = 100
    End If
    If mmm 

Function removeZeros(gA() As Long, gB() As Long, ByVal wCount As Long) As Long
    Dim q As Long
    Dim z As Long

    For q = wCount To 1 Step -1
        If gA(q) = 0 Then
            z = q
            Do While z < wCount
                gA(z) = gA(z + 1)
                gB(z) = gB(z + 1)
                z = z + 1
            Loop
            wCount = wCount - 1
        End If
    Next q
    removeZeros = wCount
End Function

برای استفاده از ماکرو، کلماتی را که می خواهید تبدیل کنید انتخاب کنید و سپس TextToNumbers را اجرا کنید. کلان مخرب است. کلمات واقعی را به معادل عددی آنها تبدیل می کند. (اگر می خواهید کلمات اصلی را حفظ کنید، قبل از اجرای ماکرو آنها را کپی کنید.)