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

• Название: Готовые макросы в vba excel, Миронов Глава Макросы 9
• Дата: 06.02.2018
• Размер: 1.35 Mb.
• Имя файла: 33980_7d1642e70814394f108d07a8a2edd23e.doc
• Тип: Документы; #35930
• страница: 47 из 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