Function SUMINWORDSEN(n As Double, curr As Variant, kop As Variant) As String
 'moonexcel.com.ua
 Dim Nums1, Nums2, Nums3, Nums4 As Variant
   
 Nums0 = Array("", "one ", "two ", "three ", "four ", "five ", "six ", "seven ", "eight ", "nine ")
 Nums1 = Array("", "one ", "two ", "three ", "four ", "five ", "six ", "seven ", "eight ", "nine ")
 Nums2 = Array("", "ten ", "twenty ", "thirty ", "forty ", "fifty ", "sixty ", "seventy ", _
                        "eighty ", "ninety ")
 Nums3 = Array("", "one hundred ", "two hundred ", "three hundred ", "four hundred ", "five hundred ", "six hundred ", "seven hundred ", _
                        "eight hundred ", "nine hundred ")
 Nums4 = Array("", "one ", "two ", "three ", "four ", "five ", "six ", "seven ", "eight ", "nine ")
 Nums5 = Array("ten ", "eleven ", "twelve ", "thirteen ", "forteen ", _
                        "fifteen ", "sixteen ", "seventeen ", "eighteen ", "ninteen ")
    
 If n < 1 Then
   SUMINWORDSEN = "Zero " & curr & " " & Round((n - Fix(n)) * 100) & " " & kop
     
If curr = "" Then
   SUMINWORDSEN = "Zero"
End If
        
   Exit Function
 End If
 'ðîçä³ëÿºìî ÷èñëî íà ðîçðÿäè, âèêîðèñòîâóþ÷è äîïîì³æíó ôóíêö³þ Class
 ed = Class(n, 1)
 dec = Class(n, 2)
 sot = Class(n, 3)
 tys = Class(n, 4)
 dectys = Class(n, 5)
 sottys = Class(n, 6)
 mil = Class(n, 7)
 decmil = Class(n, 8)
 sotmil = Class(n, 9)
 bil = Class(n, 10)
     
'ïåðåâ³ðÿºìî ì³ëüÿðäè
   
 Select Case bil
   
Case 1
     bil_txt = Nums1(bil) & "billion "
Case 2 To 4
     bil_txt = Nums1(bil) & "billions "
Case 5 To 9
     bil_txt = Nums1(bil) & "billions "
            
 End Select
     
'ïåðåâ³ðÿºìî ì³ëüéîíè
   
 Select Case sotmil
   Case 1 To 9
     sotmil_txt = Nums3(sotmil)
 End Select
    
 Select Case decmil
   Case 1
     mil_txt = Nums5(mil) & "millions "
     GoTo www
   Case 2 To 9
     decmil_txt = Nums2(decmil)
 End Select
   
 Select Case mil
 Case 0
     If decmil > 0 Then mil_txt = Nums4(mil) & "millions "
   Case 1
     mil_txt = Nums1(mil) & "million "
   Case 2, 3, 4
     mil_txt = Nums1(mil) & "million "
   Case 5 To 9
     mil_txt = Nums1(mil) & "millions "
 End Select
   
 If decmil = 0 And mil = 0 And sotmil <> 0 Then sotmil_txt = sotmil_txt & "millions "
   
www:
 sottys_txt = Nums3(sottys)
 'ïåðåâ³ðÿºìî òèñÿ÷³
 Select Case dectys
   Case 1
     tys_txt = Nums5(tys) & "thousands "
     GoTo eee
   Case 2 To 9
     dectys_txt = Nums2(dectys)
 End Select
   
 Select Case tys
   Case 0
     If dectys > 0 Then tys_txt = Nums4(tys) & "thousands "
   Case 1
     tys_txt = Nums4(tys) & "thousand "
   Case 2, 3, 4
     tys_txt = Nums4(tys) & "thousands "
   Case 5 To 9
     tys_txt = Nums4(tys) & "thousands "
 End Select
   
 If dectys = 0 And tys = 0 And sottys <> 0 Then sottys_txt = sottys_txt & " thousands "
   
eee:
 sot_txt = Nums3(sot)
 'ïåðåâ³ðÿºìî äåñÿòêè
 Select Case dec
   Case 1
     ed_txt = Nums5(ed)
     GoTo rrr
   Case 2 To 9
     dec_txt = Nums2(dec)
 End Select
    
 ed_txt = Nums0(ed)
  
rrr:
'ôîðìóºìî ï³äñóìêîâèé ðÿäîê
   
 SUMINWORDSEN = bil_txt & sotmil_txt & decmil_txt & mil_txt & sottys_txt & dectys_txt _
 & tys_txt & sot_txt & dec_txt & ed_txt & curr & " " & Round((n - Fix(n)) * 100) & " " & kop
  
If curr = "" Then
   SUMINWORDSEN = bil_txt & sotmil_txt & decmil_txt & mil_txt & sottys_txt & dectys_txt _
 & tys_txt & sot_txt & dec_txt & ed_txt
 End If
   
 SUMINWORDSEN = UCase(Mid(SUMINWORDSEN, 1, 1)) + Mid(SUMINWORDSEN, 2)
   
End Function
    
'äîïîì³æíà ôóíêö³ÿ äëÿ âèä³ëåííÿ ç ÷èñëà ðîçðÿä³â
Private Function Class(M, I)
  Class = Int(Int(M - (10 ^ I) * Int(M / (10 ^ I))) / 10 ^ (I - 1))
End Function

Option Explicit
'Main Function
Function SpellNumber(ByVal MyNumber)
    Dim Dollars, Cents, Temp
    Dim DecimalPlace, Count
    ReDim Place(9) As String
    Place(2) = " Thousand "
    Place(3) = " Million "
    Place(4) = " Billion "
    Place(5) = " Trillion "
    ' String representation of amount.
    MyNumber = Trim(Str(MyNumber))
    ' Position of decimal place 0 if none.
    DecimalPlace = InStr(MyNumber, ".")
    ' Convert cents and set MyNumber to dollar amount.
    If DecimalPlace > 0 Then
        Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & _
                  "00", 2))
        MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
    End If
    Count = 1
    Do While MyNumber <> ""
        Temp = GetHundreds(Right(MyNumber, 3))
        If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars
        If Len(MyNumber) > 3 Then
            MyNumber = Left(MyNumber, Len(MyNumber) - 3)
        Else
            MyNumber = ""
        End If
        Count = Count + 1
    Loop
    Select Case Dollars
        Case ""
            Dollars = "No Dollars"
        Case "One"
            Dollars = "One Dollar"
         Case Else
            Dollars = Dollars & " Dollars"
    End Select
    Select Case Cents
        Case ""
            Cents = " and No Cents"
        Case "One"
            Cents = " and One Cent"
              Case Else
            Cents = " and " & Cents & " Cents"
    End Select
    SpellNumber = Dollars & Cents
End Function
      
' Converts a number from 100-999 into text 
Function GetHundreds(ByVal MyNumber)
    Dim Result As String
    If Val(MyNumber) = 0 Then Exit Function
    MyNumber = Right("000" & MyNumber, 3)
    ' Convert the hundreds place.
    If Mid(MyNumber, 1, 1) <> "0" Then
        Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
    End If
    ' Convert the tens and ones place.
    If Mid(MyNumber, 2, 1) <> "0" Then
        Result = Result & GetTens(Mid(MyNumber, 2))
    Else
        Result = Result & GetDigit(Mid(MyNumber, 3))
    End If
    GetHundreds = Result
End Function
      
' Converts a number from 10 to 99 into text. 
Function GetTens(TensText)
    Dim Result As String
    Result = ""           ' Null out the temporary function value.
    If Val(Left(TensText, 1)) = 1 Then   ' If value between 10-19...
        Select Case Val(TensText)
            Case 10: Result = "Ten"
            Case 11: Result = "Eleven"
            Case 12: Result = "Twelve"
            Case 13: Result = "Thirteen"
            Case 14: Result = "Fourteen"
            Case 15: Result = "Fifteen"
            Case 16: Result = "Sixteen"
            Case 17: Result = "Seventeen"
            Case 18: Result = "Eighteen"
            Case 19: Result = "Nineteen"
            Case Else
        End Select
    Else                                 ' If value between 20-99...
        Select Case Val(Left(TensText, 1))
            Case 2: Result = "Twenty "
            Case 3: Result = "Thirty "
            Case 4: Result = "Forty "
            Case 5: Result = "Fifty "
            Case 6: Result = "Sixty "
            Case 7: Result = "Seventy "
            Case 8: Result = "Eighty "
            Case 9: Result = "Ninety "
            Case Else
        End Select
        Result = Result & GetDigit _
            (Right(TensText, 1))  ' Retrieve ones place.
    End If
    GetTens = Result
End Function
     
' Converts a number from 1 to 9 into text. 
Function GetDigit(Digit)
    Select Case Val(Digit)
        Case 1: GetDigit = "One"
        Case 2: GetDigit = "Two"
        Case 3: GetDigit = "Three"
        Case 4: GetDigit = "Four"
        Case 5: GetDigit = "Five"
        Case 6: GetDigit = "Six"
        Case 7: GetDigit = "Seven"
        Case 8: GetDigit = "Eight"
        Case 9: GetDigit = "Nine"
        Case Else: GetDigit = ""
    End Select
End Function

Sub CombineWorkbooks()
    Dim FilesToOpen
    Dim x As Integer
 
    Application.ScreenUpdating = False  'отключаем обновление экрана для скорости
     
    'вызываем диалог выбора файлов для импорта
    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="All files (*.*), *.*", _
      MultiSelect:=True, Title:="Files to Merge"
 
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Не выбрано ни одного файла!"
        Exit Sub
    End If
     
    'проходим по всем выбранным файлам
    x = 1
    While x <= UBound(FilesToOpen)
        Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))
        Sheets().Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        importWB.Close savechanges:=False
        x = x + 1
    Wend
 
    Application.ScreenUpdating = True
End Sub

Sheets().Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

Sub FormatSheet()
 
Dim sh As Worksheet
 
Application.ScreenUpdating = False
 
    For Each sh In ActiveWorkbook.Worksheets
    
     On Error Resume Next
      For i = 1 To 8
          sh.Columns.Ungroup
      Next i
     On Error GoTo 0
     
     With sh.Cells
      .Borders(xlDiagonalDown).LineStyle = xlNone
      .Borders(xlDiagonalUp).LineStyle = xlNone
      .Borders(xlEdgeLeft).LineStyle = xlNone
      .Borders(xlEdgeTop).LineStyle = xlNone
      .Borders(xlEdgeBottom).LineStyle = xlNone
      .Borders(xlEdgeRight).LineStyle = xlNone
      .Borders(xlInsideVertical).LineStyle = xlNone
      .Borders(xlInsideHorizontal).LineStyle = xlNone
      .WrapText = False
      .MergeCells = False
     End With
      
     With sh.Cells.Font
      .ColorIndex = xlAutomatic
      .Size = 8
      .Name = "Arial"
     End With
      
     sh.Cells.Interior.Pattern = xlNone
 
     sh.Cells.EntireColumn.AutoFit
     sh.Cells.EntireRow.AutoFit
      
    Next sh
    
Application.ScreenUpdating = True
 
End Sub