Главная страница
Навигация по странице:

  • Листинг 3.81.

  • Листинг 3.85.

  • Готовые макросы в vba excel, Миронов Глава Макросы 9


    Скачать 1.35 Mb.
    НазваниеГотовые макросы в vba excel, Миронов Глава Макросы 9
    Дата06.02.2018
    Размер1.35 Mb.
    Формат файлаdoc
    Имя файла33980_7d1642e70814394f108d07a8a2edd23e.doc
    ТипДокументы
    #35930
    страница47 из 47
    1   ...   39   40   41   42   43   44   45   46   47

    Вызов таблицы цветов


    Листинг 3.80. Отображение таблицы цветов

    Sub ShowColorTable()

    Dim intColor As Integer

    ' Формирование заголовка таблицы

    Range("A1").Value = "Цвет"

    Range("B1").Value = "Значение свойства ColorIndex"

    ' Вывод таблицы

    Range("A2").Select

    For intColor = 1 To 56

    ' Окрашиваем ячейку столбца "A" в текущий цвет

    With ActiveCell.Interior

    .ColorIndex = intColor

    .Pattern = xlSolid

    .PatternColorIndex = xlAutomatic

    End With

    ' В ячейку столбца "B" вносим индекс текущего цвета

    ActiveCell.Offset(0, 1).Value = intColor

    ' Переходим на следующую строку

    ActiveCell.Offset(1, 0).Activate

    Next

    ' Покажем ячейку "A1" (начало таблицы)

    Range("A1").Select

    ActiveWindow.ScrollRow = 1

    End Sub

    Создание калькулятора


    Листинг_3.81.'>Листинг 3.81. Создание калькулятора

    Sub SimpleCalculator()

    Dim strExpr As String

    ' Ввод выражения

    strExpr = InputBox("Что будем считать?")

    ' Подсчет и вывод результата

    MsgBox strExpr & " = " & Application.Evaluate(strExpr)

    End Sub

    Склонение фамилии, имени и отчества


    Листинг 3.85. Склонение ФИО

    Public Sub PossessiveCase()

    ' Склоняем ФИО в родительный падеж

    Dim strName1 As String, strName2 As String, strName3 As String

    strName1 = dhGetName(ActiveCell, 1) ' Выделяем имя

    strName2 = dhGetName(ActiveCell, 2) ' Выделяем фамилию

    strName3 = dhGetName(ActiveCell, 3) ' Выделяем отчество

    ' Если в ячейке менее трех слов - закрытие процедуры

    If strName1 = "" Or strName2 = "" Or strName3 = "" Then Exit Sub

    ' Склоняем

    Cells(ActiveCell.Row, ActiveCell.Column) = dhPossessive( _

    strName1, strName2, strName3)

    End Sub

    Public Sub DativeCase()

    ' Объявление переменных

    Dim strName1 As String, strName2 As String, strName3 As String

    strName1 = dhGetName(ActiveCell, 1)

    strName2 = dhGetName(ActiveCell, 2)

    strName3 = dhGetName(ActiveCell, 3)

    ' Если в ячейке менее трех слов - закрытие процедуры

    If Len(strName1) = 0 Or Len(strName2) = 0 Or Len(strName3) = 0 _

    Then Exit Sub

    Cells(ActiveCell.Row, ActiveCell.Column) = dhDative( _

    strName1, strName2, strName3)

    End Sub

    Function dhPossessive(strName1 As String, strName2 As String, _

    strName3 As String) As String

    Dim fMan As Boolean

    ' Определяем, мужские ФИО или женские

    fMan = (Right(strName3, 1) = "ч")

    ' Склонение фамилии в родительный падеж

    If Len(strName1) > 0 Then

    If fMan Then

    ' Склонение мужской фамилии

    Select Case Right(strName1, 1)

    Case "о", "и", "я", "а"

    dhPossessive = strName1

    Case "й"

    dhPossessive = Mid(strName1, 1, Len(strName1) - 2) + "ого"

    Case Else

    dhPossessive = strName1 + "а"

    End Select

    Else

    ' Склонение женской фамилии

    Select Case Right(strName1, 1)

    Case "о", "и", "б", "в", "г", "д", "ж", "з", "к", "л", _

    "м", "н", "п", "р", "с", "т", "ф", "х", "ц", "ч", _

    "ш", "щ", "ь"

    dhPossessive = strName1

    Case "я"

    dhPossessive = Mid(strName1, 1, Len(strName1) - 2) & "ой"

    Case Else

    dhPossessive = Mid(strName1, 1, Len(strName1) - 1) & "ой"

    End Select

    End If

    dhPossessive = dhPossessive & " "

    End If

    ' Склонение имени в родительный падеж

    If Len(strName2) > 0 Then

    If fMan Then

    ' Склонение мужского имени

    Select Case Right(strName2, 1)

    Case "й", "ь"

    dhPossessive = dhPossessive & Mid(strName2, _

    1, Len(strName2) - 1) & "я"

    Case Else

    dhPossessive = dhPossessive & strName2 & "а"

    End Select

    Else

    ' Склонение женского имени

    Select Case Right(strName2, 1)

    Case "а"

    Select Case Mid(strName2, Len(strName2) - 1, 1)

    Case "и", "г"

    dhPossessive = dhPossessive & Mid( _

    strName2, 1, Len(strName2) - 1) & "и"

    Case Else

    dhPossessive = dhPossessive & Mid(strName2, _

    1, Len(strName2) - 1) & "ы"

    End Select

    Case "я"

    If Mid(strName2, Len(strName2) - 1, 1) = "и" Then

    dhPossessive = dhPossessive & Mid(strName2, _

    1, Len(strName2) - 1) & "и"

    Else

    dhPossessive = dhPossessive & Mid(strName2, _

    1, Len(strName2) - 1) & "и"

    End If

    Case "ь"

    dhPossessive = dhPossessive & Mid(strName2, _

    1, Len(strName2) - 1) & "и"

    Case Else

    dhPossessive = dhPossessive & strName2

    End Select

    End If

    dhPossessive = dhPossessive & " "

    End If

    ' Склонение отчества в родительный падеж

    If Len(strName3) > 0 Then

    If fMan Then

    dhPossessive = dhPossessive & strName3 & "а"

    Else

    dhPossessive = dhPossessive & Mid(strName3, 1, _

    Len(strName3) - 1) & "ы"

    End If

    End If

    End Function

    Function dhDative(strName1 As String, strName2 As String, _

    strName3 As String) As String

    Dim fMan As Boolean

    ' Определяем, мужские ФИО или женские

    fMan = (Right(strName3, 1) = "ч")

    ' Склонение фамилии в дательный падеж

    If Len(strName1) > 0 Then

    If fMan Then

    ' Склонение мужской фамилии

    Select Case Right(strName1, 1)

    Case "о", "и", "я", "а"

    dhDative = strName1

    Case "й"

    dhDative = Mid(strName1, 1, Len(strName1) - 2) + "ому"

    Case Else

    dhDative = strName1 + "у"

    End Select

    Else

    ' Склонение женской фамилии

    Select Case Right(strName1, 1)

    Case "о", "и", "б", "в", "г", "д", "ж", "з", "к", "л", _

    "м", "н", "п", "р", "с", "т", "ф", "х", "ц", "ч", "ш", _

    "щ", "ь"

    dhDative = strName1

    Case "я"

    dhDative = Mid(strName1, 1, Len(strName1) - 2) & "ой"

    Case Else

    dhDative = Mid(strName1, 1, Len(strName1) - 1) & "ой"

    End Select

    End If

    dhDative = dhDative & " "

    End If

    ' Склонение имени в дательный падеж

    If Len(strName2) > 0 Then

    If fMan Then

    ' Склонение мужского имени

    Select Case Right(strName2, 1)

    Case "й", "ь"

    dhDative = dhDative & Mid(strName2, 1, _

    Len(strName2) - 1) & "ю"

    Case Else

    dhDative = dhDative & strName2 & "у"

    End Select

    Else

    ' Склонение женского имени

    Select Case Right(strName2, 1)

    Case "а", "я"

    If Mid(strName2, Len(strName2) - 1, 1) = "и" Then

    dhDative = dhDative & Mid(strName2, 1, _

    Len(strName2) - 1) & "и"

    Else

    dhDative = dhDative & Mid(strName2, 1, _

    Len(strName2) - 1) & "е"

    End If

    Case "ь"

    dhDative = dhDative & Mid(strName2, 1, _

    Len(strName2) - 1) & "и"

    Case Else

    dhDative = dhDative & strName2

    End Select

    End If

    dhDative = dhDative & " "

    End If

    ' Склонение отчества в дательный падеж

    If Len(strName3) > 0 Then

    If fMan Then

    dhDative = dhDative & strName3 & "у"

    Else

    dhDative = dhDative & Mid(strName3, 1, Len(strName3) - 1) & "е"

    End If

    End If

    End Function

    Function dhGetName(strString As String, intNum As Integer)

    ' Функция возвращает слово с номером intNum во входной строке _

    strString

    Dim strTemp As String

    Dim intWord As Integer

    Dim intSpace As Integer

    ' Удаление пробелов по краям строки

    strTemp = Trim(strString)

    ' Просмотр строки (до слова с нужным номером)

    For intWord = 1 To intNum - 1

    ' Поиск следующего пробела

    intSpace = InStr(strTemp, " ")

    If intSpace = 0 Then

    ' Строка закончилась

    intSpace = Len(strTemp)

    End If

    ' Строка strTemp теперь начинается со слова с номером intWord

    strTemp = Trim(Right(strTemp, Len(strTemp) - intSpace))

    Next intWord

    ' Выделение нужного слова (по пробелу после него)

    intSpace = InStr(strTemp, " ")

    If intSpace = 0 Then

    intSpace = Len(strTemp)

    End If

    dhGetName = Trim(Left(strTemp, intSpace))

    End Function

    ГЛАВА . ДАТА И ВРЕМЯ

    Вывод даты и времени_1


    Sub Test()

    Dim MyDate As Date

    MyDate = DateValue("6/1/72") + TimeValue("10:10:12")

    MsgBox Str(Minute(MyDate))

    MsgBox Str(Year(MyDate))

    End Sub

    Вывод даты и времени_2


    Sub TimeAndDate()

    Dim strDate As String, strTime As String

    Dim strGreeting As String

    Dim strUserName As String

    Dim intSpacePos As Integer

    strDate = Format(Date, "Long Date")

    strTime = Format(Time, "Medium Time")

    ' Приветствие - в зависимости от времени суток

    If Time < TimeValue("12:00") Then

    strGreeting = "Доброе утро, "

    ElseIf Time < TimeValue("17:00") Then

    strGreeting = "Добрый день, "

    Else

    strGreeting = "Добрый вечер, "

    End If

    ' В приветствие добавляется имя текущего пользователя

    strUserName = Application.UserName

    intSpacePos = InStr(1, strUserName, " ", 1)

    ' Управление ситуацией, когда в имени нет пробела

    If intSpacePos = 0 Then intSpacePos = Len(strUserName)

    strGreeting = strGreeting & Left(strUserName, intSpacePos)

    ' Вывод на экран информационного сообщения о дате и времени

    MsgBox strDate & vbCrLf & strTime, vbOKOnly, strGreeting

    End Sub

    Получение системной даты



    Извлечение даты и часов


    Month(переменная типа Date)

    Day(переменная типа Date)

    Year(переменная типа Date)

    Hour(переменная типа Date)

    Minute(переменная типа Date)

    Second(переменная типа Date)

    WeekDay(переменная типа Date)

    WeekDay это день недели, если Вам это нужно, то вы можете написать что-то типа этого.

    Sub Test()

    Dim MyDate As Date

    MyDate = DateValue("9/1/72")

    If (WeekDay(MyDate) = vbSunday) Then MsgBox ("Sunday")

    End Sub

    vbSunday это константа , есть еще vbMonday , ну дальше понятно.

    Функция ДатаПолная


    Function ДатаПолная(Ячейка)

    ' Получение данных в заданной ячейке в формате _

    "dd mmmm yyyy"

    Дата = Format(Ячейка, "dd mmmm yyyy")

    If IsDate(Ячейка) = True Or IsDate(Дата) = True Then

    ' Возврат строки с полной датой

    ДатаПолная = StrConv(Дата, vbProperCase)

    Else

    ' Данные в ячейке не являются датой

    ДатаПолная = "<>"

    End If

    End Function


    1   ...   39   40   41   42   43   44   45   46   47


    написать администратору сайта