mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Разное - всего понемногу

В этой статье опубликованы различные вспомогательные функции на VBA, которые порой помогают в работе.

1. Функция формирования инициалов из имени и отчества

Function CropFIO(ByVal FIO As String) As String
    ' получает в качестве параметра текстовую строку с виде "Фамилия имя отчество"
    ' обрезает имя и отчество, оставляя лишь инициалы - в виде "Фамилия И. О."
    CropFIO = Application.Trim(FIO): arr = Split(CropFIO, " ")
    If UBound(arr) <> 2 Then Exit Function    ' Если в ячейке не 3 слова - выход из процедуры
    CropFIO = Replace(CropFIO, " " & arr(1), " " & UCase(Left(arr(1), 1)) & ".")
    CropFIO = Replace(CropFIO, " " & arr(2), " " & UCase(Left(arr(2), 1)) & ".")
End Function

2. Шифрование строк на VBA

Dim s(0 To 255) As Integer, kep(0 To 255) As Integer
 
Public Function EnDeCrypt(ByVal plaintxt As String, ByVal Password As String) As String
    Dim temp As Integer, a As Integer, b As Integer, cipherby As Byte, cipher As String
    b = 0: For a = 0 To 255: b = b + 1: If b > Len(Password) Then b = 1
        kep(a) = Asc(Mid$(Password, b, 1)): Next a
    For a = 0 To 255: s(a) = a: Next a: b = 0
    For a = 0 To 255: b = (b + s(a) + kep(a)) Mod 256: temp = s(a): s(a) = s(b): s(b) = temp: Next a
    For a = 1 To Len(plaintxt): cipherby = EnDeCryptSingle(Asc(Mid$(plaintxt, a, 1)))
        cipher = cipher & Chr(cipherby): Next: EnDeCrypt = cipher
End Function
Public Function EnDeCryptSingle(plainbyte As Byte) As Byte
    Dim i As Integer, j As Integer, temp As Integer, k As Integer, cipherby As Byte
    i = (i + 1) Mod 256: j = (j + s(i)) Mod 256: temp = s(i): s(i) = s(j): s(j) = temp
    k = s((s(i) + s(j)) Mod 256): cipherby = plainbyte Xor k: EnDeCryptSingle = cipherby
End Function
 
' примеры использования
Sub Шифрование_с_расшифровкой()
    MsgBox EnDeCrypt(EnDeCrypt("123456", "passw"), "passw")
End Sub
 
Sub Тест_шифра()
    MsgBox EnDeCrypt("123456", "пароль")
End Sub

3. Сортировка двумерного массива по нулевому столбцу

Public Function CoolSort(SourceArr As Variant) As Variant
    Dim Check As Boolean, iCount As Integer, jCount As Integer, nCount As Integer
    ReDim tmpArr(UBound(SourceArr, 2)) As Variant
    Do Until Check
        Check = True
        For iCount = LBound(SourceArr, 1) To UBound(SourceArr, 1) - 1
            If Val(SourceArr(iCount, 0)) > Val(SourceArr(iCount + 1, 0)) Then
                For jCount = LBound(SourceArr, 2) To UBound(SourceArr, 2)
                    tmpArr(jCount) = SourceArr(iCount, jCount)
                    SourceArr(iCount, jCount) = SourceArr(iCount + 1, jCount)
                    SourceArr(iCount + 1, jCount) = tmpArr(jCount)
                    Check = False
                Next
            End If
        Next
    Loop
    CoolSort = SourceArr
End Function

4. Преобразование строки в набор ASC кодов

Function String2CharCodes(ByVal txt$) As String
    sep = " & "
    For i = 1 To Len(txt)
        charcode = "Chr(" & Asc(Mid(txt, i, 1)) & ")"
        String2CharCodes = String2CharCodes & sep & charcode
    Next i
    String2CharCodes = Mid(String2CharCodes, Len(sep) + 1)
End Function

5. Функции для определения нажатой клавиши

'============= Функции для определения нажатой клавиши =================================
Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As VirtualKeys) As Integer
 
Public Enum VirtualKeys    ' Virtual Keys, Standard Set
    VK_LBUTTON = &H1: VK_RBUTTON = &H2: VK_CANCEL = &H3: VK_MBUTTON = &H4    'VK_MBUTTON = &H4 -  NOT contiguous with L RBUTTON
    VK_BACK = &H8: VK_TAB = &H9: VK_CLEAR = &HC: VK_RETURN = &HD
    VK_SHIFT = &H10: VK_CONTROL = &H11: VK_MENU = &H12: VK_PAUSE = &H13: VK_CAPITAL = &H14: VK_ESCAPE = &H1B
    VK_SPACE = &H20: VK_PRIOR = &H21: VK_NEXT = &H22: VK_END = &H23: VK_HOME = &H24
    VK_LEFT = &H25: VK_UP = &H26: VK_RIGHT = &H27: VK_DOWN = &H28: VK_SELECT = &H29: VK_PRINT = &H2A
    VK_EXECUTE = &H2B: VK_SNAPSHOT = &H2C: VK_INSERT = &H2D: VK_DELETE = &H2E: VK_HELP = &H2F
 
    ' VK_A thru VK_Z are the same as their ASCII equivalents: 'A' thru 'Z'
    ' VK_0 thru VK_9 are the same as their ASCII equivalents: '0' thru '9'

    VK_NUMPAD0 = &H60: VK_NUMPAD1 = &H61: VK_NUMPAD2 = &H62: VK_NUMPAD3 = &H63: VK_NUMPAD4 = &H64
    VK_NUMPAD5 = &H65: VK_NUMPAD6 = &H66: VK_NUMPAD7 = &H67: VK_NUMPAD8 = &H68: VK_NUMPAD9 = &H69
    VK_MULTIPLY = &H6A: VK_ADD = &H6B: VK_SEPARATOR = &H6C: VK_SUBTRACT = &H6D: VK_DECIMAL = &H6E: VK_DIVIDE = &H6F
    VK_F1 = &H70: VK_F2 = &H71: VK_F3 = &H72: VK_F4 = &H73: VK_F5 = &H74: VK_F6 = &H75: VK_F7 = &H76
    VK_F8 = &H77: VK_F9 = &H78: VK_F10 = &H79: VK_F11 = &H7A: VK_F12 = &H7B
    VK_F13 = &H7C: VK_F14 = &H7D: VK_F15 = &H7E: VK_F16 = &H7F: VK_F17 = &H80: VK_F18 = &H81
    VK_F19 = &H82: VK_F20 = &H83: VK_F21 = &H84: VK_F22 = &H85: VK_F23 = &H86: VK_F24 = &H87
    VK_NUMLOCK = &H90: VK_SCROLL = &H91
 
    '   VK_L VK_R - left and right Alt, Ctrl and Shift virtual keys.
    '   Used only as parameters to GetAsyncKeyState() and GetKeyState().
    '   No other API or message will distinguish left and right keys in this way.
    VK_LSHIFT = &HA0: VK_RSHIFT = &HA1: VK_LCONTROL = &HA2: VK_RCONTROL = &HA3: VK_LMENU = &HA4: VK_RMENU = &HA5
 
    VK_ATTN = &HF6: VK_CRSEL = &HF7: VK_EXSEL = &HF8: VK_EREOF = &HF9: VK_PLAY = &HFA
    VK_ZOOM = &HFB: VK_NONAME = &HFC: VK_PA1 = &HFD: VK_OEM_CLEAR = &HFE
End Enum
'==========================================================================================

Public Function KeyPressed(ByVal VKey As VirtualKeys) As Boolean
    KeyPressed = IIf(GetKeyState(VKey) < 0, True, False)
End Function

6. Макрос для создания копии файла программы
(подразумевается наличие в программе глобальной константы или функции PROJECT_NAME)

Sub CreateBackup()
    On Error Resume Next: ThisWorkbook.Save
    BackupsPath = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, PROJECT_NAME & " Backups\")
    MkDir BackupsPath
    filename = PROJECT_NAME & "_BACKUP_" & Format(Now, "DD-MM-YYYY__HH-NN-SS") & ".xls"
    ThisWorkbook.SaveCopyAs BackupsPath & filename
    'Debug.Print BackupsPath & filename
End Sub

7. Изменяем форматирование цифр в ячейке (выделяем все цифры полужирным шрифтом)

Sub BoldingDigits(ByRef celll As Range)
    For i = 1 To celll.Characters.count
        letter = celll.Characters(start:=i, Length:=1).Text
        celll.Characters(start:=i, Length:=1).Font.Bold = IsNumeric(letter)
    Next
End Sub

8. Поиск артикула (последовательности цифр заданной длины) в текстовой строке
Ссылка на примеры использования Regexp: script-coding.com/WSH/RegExp.html

Function FindDigits(ByVal txt$, ByVal DigitsCount%) As String
    ' ищет в строке txt$ подстроку цифр длиной DigitsCount%
    Set expres = CreateObject("VBScript.RegExp")
    expres.Pattern = Replace(String(DigitsCount%, "%"), "%", "[0-9]")
    If expres.test(txt$) Then FindDigits = expres.Execute(txt$)(0).Value
End Function

Function FindDigits(ByVal txt$, ByVal DigitsCount%) As String
    ' ищет в строке txt$ подстроку цифр длиной DigitsCount%
    Set RegExp = CreateObject("VBScript.RegExp"): RegExp.Global = True
    RegExp.Pattern = "[\D]": txt$ = " " & RegExp.Replace(txt$, " ") & " "
    RegExp.Pattern = " [\d]{" & DigitsCount% & "} "
    If RegExp.test(txt$) Then FindDigits = RegExp.Execute(txt$)(0).Value
End Function

9. Добавление значений сразу во весь столбец двумерного массива

Sub AddValueIntoColumn(ByRef arr, ByVal ColumnIndex%, ByVal NewValue)
    ' добавляет значение NewValue в столбец ColumnIndex% всех строк
    ' переданного по ссылке двумерного массива arr
    For i = LBound(arr) To UBound(arr)
        arr(i, ColumnIndex%) = NewValue
    Next i
End Sub

10. Использование Application.OnTime с задержкой меньше секунды

Sub ЗапускМакросаСНебольшойЗадержкой() ' по мотивам макроса ZVI_Timer
    ЗадержкаВСекундах = 0.3    ' в секундах
    НазваниеМакроса$ = "test"    ' этот макрос будет запущен через 0.3 сек.
    ЗадержкаВЧасах$ = Replace(Format(CDbl(TimeSerial(0, 0, 1)) * ЗадержкаВСекундах, "0.000000000"), ",", ".")
    macro = "ON.TIME(NOW()+" & ЗадержкаВЧасах$ & ", """ & НазваниеМакроса$ & """)" ' формируем команду запуска
    ExecuteExcel4Macro macro ' macro = ON.TIME(NOW()+0.000003472, "test")
End Sub

11. Преобразование коллекции в массив

Function Collection2Array(ByVal coll As Collection) As Variant
    ReDim arr(0 To coll.Count - 1): Dim i As Long
    For i = 1 To coll.Count: arr(i - 1) = coll(i): Next i
    Collection2Array = arr
End Function

12. Разрешаем Excel доступ в Интернет путем отключения брандмауэра:

' включаем файрвол Windows (доступ в интернет ограничен)
CreateObject("HNetCfg.FwMgr").LocalPolicy.CurrentProfile.FirewallEnabled = True
 
' отключаем файрвол Windows (доступ в интернет открыт)
CreateObject("HNetCfg.FwMgr").LocalPolicy.CurrentProfile.FirewallEnabled = False

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

А чем событие Change листа не устраивает?

"Скажите, что вы пытаетесь сделать - наверняка найдётся более простой способ".

В Ворде2007 в статусбаре есть кнопка WordCount(Число слов)Мне кажется она отслеживает нажатие )))
Очень хочется понять ее принцип работы.

возможно ли основываясь на вашем коде сделать следующее:
при нажатии любой клавиши (находясь в редактировании или листа, ячейки или скажем документа в ворде) иметь запуск маленького макроса.
То есть макрос должен включаться при нажатии или отжатии клавиши.

А зачем запускать макрос каждый раз при вводе очередного символа?
Скажите, что вы пытаетесь сделать - наверняка найдётся более простой способ.

В общем случае, в Excel такого не сделать - когда вы редактируете текст в ячейке, никакие макросы не работают (они все приостанавливаются).
Что означает "редактирование листа" - не понял.
При изменении ячеек, переходе по листам и ячейкам макросы запускать можно - но для этого не требуется назначать макросы на нажатия клавиш - для этого в Excel существуют события листа и книги.
Могу посоветовать назначить макросы на нажатие комбинаций клавиш (например, Ctrl + буква) - но и в этом случае функция GetKeyState вам не нужна.

дико извиняюсь за первый вопрос. Понял. В период выполнения макроса он следит какая клавиша была нажата.
Всегда так сначала спрашиваю, потом думаю.

но второй вопрос остается.

позвольте узнать
5. Функции для определения нажатой клавиши
какую задачу выполняет? показывает какую клавишу нажали?

возможно ли основываясь на вашем коде сделать следующее: при нажатии любой клавиши (находясь в редактировании или листа, ячейки или скажем документа в ворде) иметь запуск маленького макроса. То есть макрос должен включаться при нажатии или отжатии клавиши.

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
  _             ____    _____   _   _         
| |_ __ _ | _ \ | ____| | | | | _ __
| __| / _` | | | | | | _| | | | | | '_ \
| |_ | (_| | | |_| | | |___ | |_| | | |_) |
\__| \__,_| |____/ |_____| \___/ | .__/
|_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.