Option Compare Text

Function ЧислоПрописью(число As Double, Optional дробная_часть As Integer = 0) As String
'
Dim DROB           ' Дробная часть входящего значения
Dim DROBCHIS As String       ' текст дробной части
Dim CHISLITELNOE As String   ' Результирующее числительное (текст)
Dim CELOE          ' Целая часть входящего значения (текст)
Dim CHAST As String
Dim clValuta As String
Dim drValuta As String
Dim n() As String            ' Отдельная цифра целой части входящего значения (текст)
Dim CIFRA() As String        ' Отдельное числительное (текст)
Dim RAZRJAD() As String      ' Наименование разряда числа (текст)
Dim Znak$
'
If Sgn(число) = -1 Then
  число = Abs(число) ' Если значение отрицательное обрабатывается его абсолютное значение
  Znak = "минус "
End If
  
If Fix(число) = число Then
  число = число + 0.0001
End If
CELOE = Split(Trim$(CStr(число)), Application.DecimalSeparator)(0) ' Удаление пробелов и отбрасывание дробной части
DROB = Split(Trim$(CStr(число)), Application.DecimalSeparator)(1) ' Дробная часть
Select Case Len(DROB)
  Case Is < 3
    DROB = DROB & String(3 - Len(DROB), "0")
  Case Is > 3
    DROB = Left(DROB, 3)
End Select

ReDim n(1 To Len(CELOE)) As String        ' Определение размерности массивов
ReDim CIFRA(Len(CELOE)) As String
ReDim RAZRJAD(Len(CELOE)) As String

CHISLITELNOE = vbNullString
DROBCHIS = vbNullString

CHAST = CELOE
For I = 1 To Len(CELOE)      ' Основной блок процедуры
    n(I) = Mid$(CELOE, Len(CELOE) - I + 1, 1)
    GoSub ObrabotkaRazryadov
Next I

For I = 1 To Len(CELOE) ' Формирование числительного
    CHISLITELNOE = CIFRA(I) & RAZRJAD(I) & CHISLITELNOE
Next I

'Если нужно с Прописной буквы
'Mid$(CHISLITELNOE, 1, 1) = StrConv(Left$(CHISLITELNOE, 1), vbProperCase)

ReDim n(1 To Len(DROB)) As String       ' переопределение размерности массивов
ReDim CIFRA(Len(DROB)) As String

CHAST = DROB

For I = 1 To Len(DROB)     ' преобразование дробной части
    n(I) = Mid$(DROB, Len(DROB) - I + 1, 1)
    GoSub ObrabotkaRazryadov
Next I
    
For I = 1 To Len(DROB) ' Формирование дробной части числительного
    DROBCHIS = CIFRA(I) & Trim$(DROBCHIS)
Next I

If дробная_часть = 0 Then DROBOR = Val(DROB) Else DROBOR = Trim$(DROBCHIS)

clValuta = IIf(clValuta = "", "целых ", clValuta)
drValuta = IIf(drValuta = "", " тысячных", drValuta)

ЧислоПрописью = Znak & CHISLITELNOE & clValuta & DROBOR & drValuta
Exit Function

ObrabotkaRazryadov:   'Подпрограмма обработки разрядов
'       Единицы
    If I = 1 Or I = 4 Or I = 7 Or I = 10 Then
        If Len(CHAST) = 1 And n(I) = "0" Or CHAST = "00" Or CHAST = "000" Then CIFRA(I) = "ноль "
        If n(I) = "1" Then
          CIFRA(I) = "одна "
          If CHAST = CELOE Then clValuta = "целая "
          If CHAST = DROB Then drValuta = " тысячная"
        End If
'            If I = 4 And n(I) = "1" Then CIFRA(I) = "одна "   ' единицы тысяч
        If n(I) = "2" Then CIFRA(I) = "две "
'            If I = 4 And n(I) = "2" Then CIFRA(I) = "две "    ' единицы тысяч
        If n(I) = "3" Then CIFRA(I) = "три "
        If n(I) = "4" Then CIFRA(I) = "четыре "
        If n(I) = "5" Then CIFRA(I) = "пять "
        If n(I) = "6" Then CIFRA(I) = "шесть "
        If n(I) = "7" Then CIFRA(I) = "семь "
        If n(I) = "8" Then CIFRA(I) = "восемь "
        If n(I) = "9" Then CIFRA(I) = "девять "
    End If
'       Десятки
    If I = 2 Or I = 5 Or I = 8 Or I = 11 Then
        If n(I) = "0" Then CIFRA(I) = vbNullString
            
            If n(I) = "1" And n(I - 1) = "0" Then CIFRA(I - 1) = "десять "
            If n(I) = "1" And n(I - 1) = "1" Then CIFRA(I - 1) = "одиннадцать "
            If n(I) = "1" And n(I - 1) = "2" Then CIFRA(I - 1) = "двенадцать "
            If n(I) = "1" And n(I - 1) = "3" Then CIFRA(I - 1) = "тринадцать "
            If n(I) = "1" And n(I - 1) = "4" Then CIFRA(I - 1) = "четырнадцать "
            If n(I) = "1" And n(I - 1) = "5" Then CIFRA(I - 1) = "пятнадцать "
            If n(I) = "1" And n(I - 1) = "6" Then CIFRA(I - 1) = "шестнадцать "
            If n(I) = "1" And n(I - 1) = "7" Then CIFRA(I - 1) = "семнадцать "
            If n(I) = "1" And n(I - 1) = "8" Then CIFRA(I - 1) = "восемнадцать "
            If n(I) = "1" And n(I - 1) = "9" Then CIFRA(I - 1) = "девятнадцать "
            
        If n(I) = "2" Then CIFRA(I) = "двадцать "
        If n(I) = "3" Then CIFRA(I) = "тридцать "
        If n(I) = "4" Then CIFRA(I) = "сорок "
        If n(I) = "5" Then CIFRA(I) = "пятьдесят "
        If n(I) = "6" Then CIFRA(I) = "шестьдесят "
        If n(I) = "7" Then CIFRA(I) = "семьдесят "
        If n(I) = "8" Then CIFRA(I) = "восемьдесят "
        If n(I) = "9" Then CIFRA(I) = "девяносто "
    End If
    If I = 3 Or I = 6 Or I = 9 Or I = 12 Then
'       Сотни
        If n(I) = "0" Then CIFRA(I) = vbNullString
        If n(I) = "1" Then CIFRA(I) = "сто "
        If n(I) = "2" Then CIFRA(I) = "двести "
        If n(I) = "3" Then CIFRA(I) = "триста "
        If n(I) = "4" Then CIFRA(I) = "четыреста "
        If n(I) = "5" Then CIFRA(I) = "пятьсот "
        If n(I) = "6" Then CIFRA(I) = "шестьсот "
        If n(I) = "7" Then CIFRA(I) = "семьсот "
        If n(I) = "8" Then CIFRA(I) = "восемьсот "
        If n(I) = "9" Then CIFRA(I) = "девятьсот "
    End If
    ' Тысячи
    If I = 4 Then
        If Val(n(I)) = 0 Or Val(n(I)) > 4 Then RAZRJAD(I) = "тысяч "
        If Val(n(I)) = 1 Then RAZRJAD(I) = "тысяча "
        If Val(n(I)) >= 2 And Val(n(I)) <= 4 Then RAZRJAD(I) = "тысячи "
    End If
    If I = 5 Then
        If Val(n(I)) = 1 Then RAZRJAD(I - 1) = "тысяч "
    End If
    If I = 6 Then
        If Val(n(I)) = 0 And Val(n(I - 1)) = 0 And Val(n(I - 2)) = 0 Then RAZRJAD(I - 2) = vbNullString
    End If
            ' Миллионы
    If I = 7 Then
        If Val(n(I)) = 0 Or Val(n(I)) > 4 Then RAZRJAD(I) = "миллионов "
        If Val(n(I)) = 1 Then RAZRJAD(I) = "миллион "
        If Val(n(I)) >= 2 And Val(n(I)) <= 4 Then RAZRJAD(I) = "миллиона "
    End If
    If I = 8 Then
        If Val(n(I)) = 1 Then RAZRJAD(I - 1) = "миллионов "
    End If
    If I = 9 Then
        If Val(n(I)) = 0 And Val(n(I - 1)) = 0 And Val(n(I - 2)) = 0 Then RAZRJAD(I - 2) = vbNullString
    End If
            ' Миллиарды
     If I = 10 Then
        If Val(n(I)) = 0 Or Val(n(I)) > 4 Then RAZRJAD(I) = "миллиардов "
        If Val(n(I)) = 1 Then RAZRJAD(I) = "миллиард "
        If Val(n(I)) >= 2 And Val(n(I)) <= 4 Then RAZRJAD(I) = "миллиарда "
    End If
    If I = 11 Then
        If Val(n(I)) = 1 Then RAZRJAD(I - 1) = "миллиардов "
    End If
Return

End Function

Sub SelectFileAndCopy()

Dim MyFile As String
Dim iWb As Workbook
 
 Application.ScreenUpdating = False
 Application.EnableEvents = False
On Error Resume Next
 'Select file(s) in Mac Excel, you are only able to select the file format that you want,
 'with this custom GetOpenFilename function, the built-infunction is not working correct on the Mac
 'Ron de Bruin, 9-Dec-2024. For more info visit the webpage below
 'https://macexcel.com/examples/filesandfolders/selectfiles/
 
'The first argument is the Folder that opens by default, If the second argument is False you be able to select more than one file, If True only one file, the third argument is the file filter
'In this example you are only be able to select xls, xlsx and xlsm files, other examples you can find on my webpage
MyFile = GetOpenFileNameMac(ThisWorkbook.Path, False, _
                "{""com.microsoft.Excel.xls"",""org.openxmlformats.spreadsheetml.sheet"",""org.openxmlformats.spreadsheetml.sheet.macroenabled""}")

If bIsBookOpen(MyFile) = False Then
  Set iWb = Workbooks.Open(MyFile)
ElseIf MsgBox("Файл " & MyFile & " уже открыт. Продолжить работу с ним?", vbQuestion + vbYesNo, "Внимание!") = vbNo Then
  Exit Sub
End If

If MsgBox("Загрузить данные на лист Газа?", vbQuestion + vbYesNo, "Загрузка данных") = vbNo Then Exit Sub

With ThisWorkbook.Worksheets("Газа")
  .Range("A2:H10000").Cells.Clear
  iWb.Worksheets("Лист_1").Range("A13:H4000").Copy .Range("A2")
End With
 Application.EnableEvents = True
 Application.ScreenUpdating = True
End Sub

Function GetOpenFileNameMac(StartFolder As String, OneFile As Boolean, FileFilter As String) As String
 'Select file(s) in Mac Excel, you are only able to select the file format that you want,
 'Ron de Bruin, 9-Dec-2024. For more info visit the webpage below
 'https://macexcel.com/examples/filesandfolders/selectfiles/
 On Error Resume Next
  If OneFile = True Then
   MyScript = _
           "set theFile to (choose file of type" & _
           " " & FileFilter & " " & _
           "with prompt ""Please select a file"" default location alias POSIX file (""" & _
           StartFolder & """) " & "without multiple selections allowed) as string" & vbNewLine & _
           "return posix path of theFile"
   Else
       MyScript = _
           "set theFiles to (choose file of type" & _
           " " & FileFilter & " " & _
           "with prompt ""Please select a file or files"" default location alias POSIX file (""" & _
           StartFolder & """) " & "with multiple selections allowed)" & vbNewLine & _
           "set thePOSIXFiles to {}" & vbNewLine & _
           "repeat with aFile in theFiles" & vbNewLine & _
           "set end of thePOSIXFiles to POSIX path of aFile" & vbNewLine & _
           "end repeat" & vbNewLine & _
           "set {TID, text item delimiters} to {text item delimiters, ASCII character 10}" & vbNewLine & _
           "set thePOSIXFiles to thePOSIXFiles as text" & vbNewLine & _
           "set text item delimiters to TID" & vbNewLine & _
           "return thePOSIXFiles"
   End If
GetOpenFileNameMac = MacScript(MyScript)
On Error GoTo 0
End Function

Function bIsBookOpen(ByRef szBookName As String) As Boolean
  On Error Resume Next
  bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function

Sub ShowGetOpenDialod()
    Dim avFiles
    Dim wb As Workbook
    'по умолчанию к выбору доступны файлы Excel(xls,xlsx,xlsm,xlsb)
    avFiles = Application.GetOpenFilename _
                ("Excel files(*.xls*),*.xls*", 1, "Выбрать Excel файлы", , False)
    If VarType(avFiles) = vbBoolean Then Exit Sub
    Set wb = Workbooks.Open(avFiles)
    Call Copy1(wb)
    wb.Close False
    MsgBox "Данные успешно скопированы!"
End Sub
 
Private Sub Copy1(iWb As Workbook)
    Dim sourceWorkbook As Workbook
    Dim targetWorkbook As Workbook
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim sourceRange As Range
    Dim targetRange As Range
 
    If MsgBox("Загрузить данные на лист Газа?", vbQuestion + vbYesNo, "Загрузка данных") = vbNo Then Exit Sub
     
 
    ' “кажите путь к исходной книге
    Set sourceWorkbook = iWb  'Workbooks.Open("/Users/alex/Yandex.Disk.localized/„лЯ отчетов/ЂЉЃ џдро XLS.xls")
    Set targetWorkbook = ThisWorkbook ' –елеваЯ книга - это книга, в которой находитсЯ макрос
    Set sourceSheet = sourceWorkbook.Sheets("Лист_1") ' “кажите имЯ листа в исходной книге
    Set targetSheet = targetWorkbook.Sheets("Газа") ' “кажите имЯ листа в целевой книге
 
    'очищаем данные на листе Ѓаза
    targetSheet.Range("A2:H10000").Cells.Clear
    ' “кажите диапазон длЯ копированиЯ
    Set sourceRange = sourceSheet.Range("A13:H4000") ' €змените диапазон по мере необходимости
    Set targetRange = targetSheet.Range("A2") ' ЌачальнаЯ Ячейка длЯ вставки данных
 
    ' Љопирование и вставка данных
    sourceRange.Copy targetRange
 
End Sub