я совсем забыл сказать, что для корректной работы моего кода нужно в свойствах комбобокса нужно очистить свойство LisFfillRange и установить MatchEntry fmMatchEntryNone , немного переписал код, добавил комментарии [vba]
Код
Private Sub ComboBox1_Change() Dim arr As Variant, r&, v As Variant With ComboBox1 If Len(.Value) Then 'пишем в массив значения из диапазона от C3 до последней непустой ячейки в C:C arr = Application.Transpose([c3].Resize(Cells(Rows.Count, 2).End(xlUp).Row - 3).Value) 'Application.Transpose нужен для получения горизонтального массива, 'ибо функция Filter с вертикальными массивами работать отказывается
On Error Resume Next 'отключаем отлов ошибок 'очищаем список: задаем список массивом, фильтрованным по значению в ComboBox1: разворачиваем список .List = Array(): .List = Filter(arr, IIf(Len(.Value), .Value, "џ"), 1, 1): .DropDown: DoEvents 'если список пуст или значение не задано, "жмем" Escape, чтобы его свернуть и завершаем процедуру End If If UBound(.List) < 0 Or Len(.Value) = 0 Then Application.SendKeys "{ESC}", 1: DoEvents: .Activate: Exit Sub 'если в ComboBox1 числовое значение, конвертируем в число 'число, записанное текстом, тоже распознается как числовое If IsNumeric(.Value) Then v = --.Value Else v = .Value Err.Clear 'очищаем информацию об ошибке 'ищем значение ComboBox1 в массиве, и прокручиваем лист до соответствующей ячейки Application.Goto Range("C3")(Application.Match(v, arr, 0)), 1 End With If Err = 0 Then 'если значение было найдено 'снимаем окрашивание со столбца Columns("C:C").Interior.Pattern = xlNone 'красим ячейку Selection.Interior.ColorIndex = 8 End If End Sub
[/vba]
я совсем забыл сказать, что для корректной работы моего кода нужно в свойствах комбобокса нужно очистить свойство LisFfillRange и установить MatchEntry fmMatchEntryNone , немного переписал код, добавил комментарии [vba]
Код
Private Sub ComboBox1_Change() Dim arr As Variant, r&, v As Variant With ComboBox1 If Len(.Value) Then 'пишем в массив значения из диапазона от C3 до последней непустой ячейки в C:C arr = Application.Transpose([c3].Resize(Cells(Rows.Count, 2).End(xlUp).Row - 3).Value) 'Application.Transpose нужен для получения горизонтального массива, 'ибо функция Filter с вертикальными массивами работать отказывается
On Error Resume Next 'отключаем отлов ошибок 'очищаем список: задаем список массивом, фильтрованным по значению в ComboBox1: разворачиваем список .List = Array(): .List = Filter(arr, IIf(Len(.Value), .Value, "џ"), 1, 1): .DropDown: DoEvents 'если список пуст или значение не задано, "жмем" Escape, чтобы его свернуть и завершаем процедуру End If If UBound(.List) < 0 Or Len(.Value) = 0 Then Application.SendKeys "{ESC}", 1: DoEvents: .Activate: Exit Sub 'если в ComboBox1 числовое значение, конвертируем в число 'число, записанное текстом, тоже распознается как числовое If IsNumeric(.Value) Then v = --.Value Else v = .Value Err.Clear 'очищаем информацию об ошибке 'ищем значение ComboBox1 в массиве, и прокручиваем лист до соответствующей ячейки Application.Goto Range("C3")(Application.Match(v, arr, 0)), 1 End With If Err = 0 Then 'если значение было найдено 'снимаем окрашивание со столбца Columns("C:C").Interior.Pattern = xlNone 'красим ячейку Selection.Interior.ColorIndex = 8 End If End Sub
Sub dd() Dim xcell As Variant xcell = Range("A2").Value Select Case 1 Case InStr(xcell, "абв.") MsgBox "абв." Case InStr(xcell, "аб.") MsgBox "аб." Case InStr(xcell, "а.") MsgBox "а." End Select End Sub
Sub dd() Dim xcell As Variant xcell = Range("A2").Value Select Case 1 Case InStr(xcell, "абв.") MsgBox "абв." Case InStr(xcell, "аб.") MsgBox "аб." Case InStr(xcell, "а.") MsgBox "а." End Select End Sub
Евгений, спасибо, понравилось. После небольшого тестирования захотелось "мультипроцессности" и решил немного доработать Вот чего у мну получилось (в конце я немного поизвращался над формой )
Евгений, спасибо, понравилось. После небольшого тестирования захотелось "мультипроцессности" и решил немного доработать Вот чего у мну получилось (в конце я немного поизвращался над формой )krosav4ig
Sub test() With New IniFile .INIFileName = "d:\1.ini" .WritePrivateINIString 1, 2, 3 Debug.Print .GetPrivateINIString(1, 2) .WritePrivateINIString 4, 5, 6 Debug.Print .GetPrivateINIString(4, 5) End With End Sub
[/vba]
или в ini файл, например [vba]
Код
Sub test() With New IniFile .INIFileName = "d:\1.ini" .WritePrivateINIString 1, 2, 3 Debug.Print .GetPrivateINIString(1, 2) .WritePrivateINIString 4, 5, 6 Debug.Print .GetPrivateINIString(4, 5) End With End Sub
еще вариант, для работы нужно включить итеративные вычисления Кнопками 1 и 2 перегенерируются левая и правая таблицы соответственно Кнопкой 3 перезапускается шифровка/дешифровка, после нажатия на нее нужно выделить любую ячейку и зажать F9 на кнопки нужно жать двойным кликом
еще вариант, для работы нужно включить итеративные вычисления Кнопками 1 и 2 перегенерируются левая и правая таблицы соответственно Кнопкой 3 перезапускается шифровка/дешифровка, после нажатия на нее нужно выделить любую ячейку и зажать F9 на кнопки нужно жать двойным кликомkrosav4ig
Option Explicit Private Type DOCINFO pDocName As String pOutputFile As String pDatatype As String End Type Private Declare Function ClosePrinter _ Lib "winspool.drv" ( _ ByVal hPrinter As Long _ ) As Long Private Declare Function EndDocPrinter _ Lib "winspool.drv" ( _ ByVal hPrinter As Long _ ) As Long Private Declare Function EndPagePrinter _ Lib "winspool.drv" ( _ ByVal hPrinter As Long _ ) As Long Private Declare Function OpenPrinter _ Lib "winspool.drv" _ Alias "OpenPrinterA" ( _ ByVal pPrinterName As String, _ phPrinter As Long, _ ByVal pDefault As Long _ ) As Long Private Declare Function StartDocPrinter _ Lib "winspool.drv" _ Alias "StartDocPrinterA" ( _ ByVal hPrinter As Long, _ ByVal Level As Long, _ pDocInfo As DOCINFO _ ) As Long Private Declare Function StartPagePrinter _ Lib "winspool.drv" ( _ ByVal hPrinter As Long _ ) As Long Private Declare Function WritePrinter _ Lib "winspool.drv" ( _ ByVal hPrinter As Long, _ pBuf As Any, _ ByVal cdBuf As Long, _ pcWritten As Long _ ) As Long
Public Sub PrintStr(sWrittenData As String, Optional prn As String) Dim lhPrinter As Long Dim lReturn As Long Dim lpcWritten As Long Dim lDoc As Long
Dim MyDocInfo As DOCINFO If Len(prn) = 0 Then prn = ActivePrinter prn = Left(prn, InStr(prn & " (Ne", "(Ne") - 2) lReturn = OpenPrinter(prn, lhPrinter, 0) If lReturn = 0 Then MsgBox "Принтер не найден" Exit Sub End If MyDocInfo.pDocName = "AAAAAA" MyDocInfo.pOutputFile = vbNullString MyDocInfo.pDatatype = vbNullString lDoc = StartDocPrinter(lhPrinter, 1, MyDocInfo) Call StartPagePrinter(lhPrinter) lReturn = WritePrinter(lhPrinter, _ ByVal (sWrittenData & vbFormFeed), _ Len(sWrittenData), lpcWritten) lReturn = EndPagePrinter(lhPrinter) lReturn = EndDocPrinter(lhPrinter) lReturn = ClosePrinter(lhPrinter) End Sub
[/vba]
использование в коде [vba]
Код
call PrintStr("Текст который нужно печатать","Имя принтера")
[/vba] Второй аргумент не обязателен, если его не указывать, будет печататься на активный принтер [vba]
Код
Sub dd() Dim s$ s = "Текст" If MsgBox(s, 4, "Печатать?") = vbYes Then PrintStr s End Sub
[/vba]
можно как-то так
[vba]
Код
Option Explicit Private Type DOCINFO pDocName As String pOutputFile As String pDatatype As String End Type Private Declare Function ClosePrinter _ Lib "winspool.drv" ( _ ByVal hPrinter As Long _ ) As Long Private Declare Function EndDocPrinter _ Lib "winspool.drv" ( _ ByVal hPrinter As Long _ ) As Long Private Declare Function EndPagePrinter _ Lib "winspool.drv" ( _ ByVal hPrinter As Long _ ) As Long Private Declare Function OpenPrinter _ Lib "winspool.drv" _ Alias "OpenPrinterA" ( _ ByVal pPrinterName As String, _ phPrinter As Long, _ ByVal pDefault As Long _ ) As Long Private Declare Function StartDocPrinter _ Lib "winspool.drv" _ Alias "StartDocPrinterA" ( _ ByVal hPrinter As Long, _ ByVal Level As Long, _ pDocInfo As DOCINFO _ ) As Long Private Declare Function StartPagePrinter _ Lib "winspool.drv" ( _ ByVal hPrinter As Long _ ) As Long Private Declare Function WritePrinter _ Lib "winspool.drv" ( _ ByVal hPrinter As Long, _ pBuf As Any, _ ByVal cdBuf As Long, _ pcWritten As Long _ ) As Long
Public Sub PrintStr(sWrittenData As String, Optional prn As String) Dim lhPrinter As Long Dim lReturn As Long Dim lpcWritten As Long Dim lDoc As Long
Dim MyDocInfo As DOCINFO If Len(prn) = 0 Then prn = ActivePrinter prn = Left(prn, InStr(prn & " (Ne", "(Ne") - 2) lReturn = OpenPrinter(prn, lhPrinter, 0) If lReturn = 0 Then MsgBox "Принтер не найден" Exit Sub End If MyDocInfo.pDocName = "AAAAAA" MyDocInfo.pOutputFile = vbNullString MyDocInfo.pDatatype = vbNullString lDoc = StartDocPrinter(lhPrinter, 1, MyDocInfo) Call StartPagePrinter(lhPrinter) lReturn = WritePrinter(lhPrinter, _ ByVal (sWrittenData & vbFormFeed), _ Len(sWrittenData), lpcWritten) lReturn = EndPagePrinter(lhPrinter) lReturn = EndDocPrinter(lhPrinter) lReturn = ClosePrinter(lhPrinter) End Sub
[/vba]
использование в коде [vba]
Код
call PrintStr("Текст который нужно печатать","Имя принтера")
[/vba] Второй аргумент не обязателен, если его не указывать, будет печататься на активный принтер [vba]
Код
Sub dd() Dim s$ s = "Текст" If MsgBox(s, 4, "Печатать?") = vbYes Then PrintStr s End Sub
Sub Макрос3() With ActiveDocument.Range.Font.Shading .Texture = wdTextureNone .ForegroundPatternColor = wdColorAutomatic .BackgroundPatternColor = wdColorAutomatic End With End Sub
Интересное кино. Если выделять вместе со знаком абзаца, не работает, без него - на урЯ!
ибо
Roman777, а если так? [vba]
Код
Sub Макрос3() With ActiveDocument.Range.Font.Shading .Texture = wdTextureNone .ForegroundPatternColor = wdColorAutomatic .BackgroundPatternColor = wdColorAutomatic End With End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
#Этнияоносамо
