Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Пользователи » Григорий Калюга
Выбрать дату в календаре…Выбрать дату в календаре

Страницы: 1
Autofilter запускает пользовательский макрос, Autofilter запускает пользовательский макрос
 
#
30.12.2024 01:32:54
Добрый день, друзья!
Собственно вопрос в названии: Autofilter запускает пользовательский макрос - как это сделать?
На листе таблица, по столбцу, выполняется Autofilter, после его выполнения происходит запуск макроса.
 
Перейти    
на VBA вставить в ячейку спецзнак, на VBA вставить в ячейку знак, получаемый при вводе с клавиатуры Alt + 31
 
#
30.06.2023 22:48:16
Добрый день, коллеги!
нужно чтобы при работе макроса в ячейку записывался символ "треугольник с вершиной вниз", который можно получить при вводе с клавиатуры комбинации клавиш Alt + 31 (31 - на цифровой клавиатуре).
Написал код:
Код
Sub test2()
    ActiveCell.Select
    
    With Application
        .SendKeys "%{31}"
    End With
    
    With Selection
        With .Font
            .ThemeColor = xlThemeColorAccent6
            .TintAndShade = -0.249977111117893
        End With
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
End Sub

работает все, кроме вставки самого символа. Он не вставляется. Может кто подскажет, в чем ошибка?
Изменено: Григорий Калюга - 30.06.2023 22:51:31
 
Перейти    
из .pdf в ячейку листа Excel
 
#
03.04.2023 15:14:12
Добрый день!
Есть набор файлов .pdf, их имена записаны в таблицу. Возможен ли следующий сценарий: "идем" по ячейкам таблицы с именами, открываем файлы .pdf и из каждого открытого файла копируем текст в ячейку таблицы Excel, правее ячейки с именем?
 
Перейти    
AutoFilter и Shapes, Оставить видимыми картинки только к нескрытым Автофильтром строкам
 
#
13.02.2023 08:52:54
Добрый день!
Есть некий набор данных, с картинками: рисунок 1
Собственно задача в описании темы: Оставить видимыми картинки только к нескрытым Автофильтром строкам.
У меня же получается как на рисунке 2.

Помогите, пожалуйста, решить проблему? Спасибо!
Изменено: Григорий Калюга - 13.02.2023 08:53:56
 
Перейти    
в .pdf два блока данных с одного листа
 
#
03.02.2023 23:24:34
Добрый день, друзья!
На листе Excel размещаются два блока значений. Нужно сохранить в .pdf-файл: на 1-й странице - большой блок; на 2-й странице - малый.

Само сохранение сделал - работает, а вот как сделать, чтобы большой блок вписывался в 1-ю страницу а, малый строго во 2-ую не знаю.
Может у кого есть идеи и решения?
 
Перейти    
Выдача задания исполнителю через Telegram
 
#
02.01.2023 10:58:42
Добрый день, друзья!
Всех с Новым годом!
Есть идея организовать рассылку из таблицы Excel, заданий Исполнителям на их мобильные телефоны. И как вариант, поскольку нынче у всех (а если нет, то установят) установлен Telegram, то отправлять задания Исполнителям в Telegram и, получать от них подтверждение, что задание получено. Ну, а по факту исполнения, что выполнено...
Таблицу в Excel организовал, а вот дальше как сделать - не знаю. Может у кого есть идеи?
Всем откликнувшимся СПАСИБО!
 
Перейти    
Отменить выделение строк при активной UserForm
 
#
29.12.2022 23:08:31
Доброго времени суток, друзья!
Прошу помочь: сделал файл, при добавлении блока строк не получается завершить выделение добавленного блока.
Может кто знает, каким образом это реализовать?
Изменено: Григорий Калюга - 29.12.2022 23:09:18
 
Перейти    
VBA, назначить макрос кнопке в UserForm
 
#
10.12.2022 23:41:10
Доброго времени суток, друзья!
Есть задача: создать кодом VBA UserForm, разместить на ней несколько Controls, в том числе CommandButton. Это все реализовано, а вот как назначить кодом VBA, кнопке макрос, который будет запускаться при ее нажатии, не соображу никак? - Подскажите, пожалуйста! В саму UserForm "залезать" не хотелось бы ...
 
Перейти    
ВБА Не берем лист по маске
 
#
08.12.2022 20:35:58
Доброго дня, друзья!
Есть книга с множеством листов: Lis_1; Bus_2 ... Вася_nnn; ШАБЛОН; _; рЗНзкр_20221208221248; рЗНзкр_20221208221526 ... рЗНзкр_ггггммддччммсс
так вот, нужно обработать все листы,  кроме: ШАБЛОН; _; рЗНзкр_20221208221248; рЗНзкр_20221208221526 ... рЗНзкр_ггггммддччммсс
и если бы это были только листы: ШАБЛОН; _; то нет проблем:
Код
    For Each mySheet In myWorkbook.Sheets
        'по всем листам, кроме "ШАБЛОН" и "_"
        If mySheet.Name <> "ШАБЛОН" And mySheet.Name <> "_" Then
        End If
   Next


а вот теперь вопрос, можно ли файлы вида: рЗНзкр_20221208221248; рЗНзкр_20221208221526 ... рЗНзкр_ггггммддччммсс
распознать по маске, типа:
Код
    For Each mySheet In myWorkbook.Sheets
        'по всем листам, кроме "ШАБЛОН" и "_"
        If mySheet.Name <> "ШАБЛОН" And mySheet.Name <> "_" And mySheet.Name <> "рЗНзкр_*" Then
        End If
   Next

но, это не работает. Может кто подскажет, как реализовать в конструкции If ... End If условие по маске?

Да вот еще, нашел тут: https://www.planetaexcel.ru/techniques/7/97/
но, как это встроить в решение моей задачи?
Изменено: БМВ - 08.12.2022 20:56:31
 
Перейти    
Вернуть курсор в TextBox на VBA
 
#
28.11.2022 17:55:10
Добрый день, друзья!
Есть вот такая разработка (прикрепил файл).
Вопрос следующий: На UserForm есть 2 TextBox и 1 ListBox.
TextBox-ы это поля ввода состоящего из 2-х частей номера, вида 000 \ 000. Если вторая часть введена неправильно, нужно, выдать сообщение пользователю и пригласить его (мигающим курсором) к повторному вводу варианта. Попробовал сделать так:
Код
            MsgBox "Диапазон допустимых значений: целое число от 1 до 12", vbCritical + vbOKOnly, "Значение вне диапазона:"
            znac = " "
            With Me
                With .tbx_NomDetalB
                    .Text = znac
                    
                    .SelStart = 1
                    .SetFocus
                    
                    ht = .Top + .Height + 35
                    wt = .Left + .Width + 15
                End With
                .Height = ht
                .Width = wt
            End With
                
            Exit Sub
, но, .SetFocus - не работает.
Есть идеи?
Всем откликнувшимся - спасибо!
 
Перейти    
привязать одну Shape к другой.
 
#
02.11.2022 20:18:46
Доброго времени суток, друзья!
Сделал вот так:
Код
Sub test()
    Dim ws As Worksheet
    Dim nm As Integer
    
    nm = 1
    Set ws = ThisWorkbook.ActiveSheet
'==-<>-==
    With ws
        Set fig1 = .Shapes.AddShape(Type:=msoShapeRectangle, _
                         Left:=35, _
                         Top:=40, _
                         Width:=60, _
                         Height:=40)
    End With

    With fig1
        .Name = "Rectangle_" & nm ' - присваиваем имя
        .Fill.ForeColor.RGB = RGB(0, 112, 50) ' - заливка поля цветом (светло-зеленый)
        .Line.ForeColor.SchemeColor = 12 ' - красим окантовку
    End With
'==-<>-==
    With fig1
        lft = .Left + .Width * 2
        tpp = .Top
        wdh = 190
        hgt = 90
    End With
'==-<>-==
    With ws
        Set fig2 = .Shapes.AddShape(Type:=msoShapeRoundedRectangularCallout, _
                         Left:=lft, _
                         Top:=tpp, _
                         Width:=wdh, _
                         Height:=hgt)
    End With

    With fig2
        .Adjustments.Item(1) = -0.74473
        .Adjustments.Item(2) = -0.50577
    End With
'==-<>-==
    Set ws = Nothing
End Sub

получилось, как на скриншоте
Вопрос: как посчитать координаты для желтой точки так, чтобы она "привязалась" к правому верхнему углу "Rectangle_1". И если возможно, то чтобы точка привязки не менялась, если пользователь начнет двигать одну из фигур?
Всем откликнувшимся, буду рад и глубоко признателен.
Изменено: Григорий Калюга - 02.11.2022 20:27:23
 
Перейти    
Как снять пометку выбора с пункта в ListBox
 
#
26.10.2022 20:11:18
Доброго дня!

Перепробовал:
Код
'Листбокс без мультиселекта:

ListBox1.ListIndex = -1

'С мультиселектом:

Dim i as String
For i = 0 To ListBox1.ListCount - 1
    ListBox1.Selected(i) = False
Next
не срабатывает. Снять выделение не получается. Может есть идеи у кого? Или примеры покажите.
Заранее спасибо.
 
Перейти    
Заготовка для расчета площади прямоугольника, круга и равностороннего треугольника
 
#
26.10.2022 19:47:25
Доброго дня, друзья!
Вот, периодически возникает задача из таблицы, содержащей характеристики изделий, вытащить размеры и по ним рассчитать площадь. Изделия могут иметь форму прямоугольника или равностороннего треугольника или круга. Таких строк в таблице с характеристиками бывает до 100, поэтому написал макрос, который "готовит" шаблон для выполнения расчета площади. Правда, ввиду разнообразия "талантливого подхода" к описанию изделий у заказчиков, ввод длины и высоты прямоугольника; длину стороны треугольника; диаметр круга - ввожу ручками.
Короче, вот хочу поделится с вами своим "творчеством". Опытным, вероятно - не потребуется, а новички, глядишь - воспользуются ...
Код
Sub Calc_Sm2()
'
' Calc_Sm2 Макрос
' Создание таблицы-заготовки для исчисления площадей прг_, трг_, крг_.
'
' Сочетание клавиш: Ctrl+Shift+U
'
    Dim i As Integer
    Dim flg As Boolean, fff As Boolean
    Dim cL As Range, S As Range
    
    Set cL = ActiveCell
    
    With cL
        'проверяем строку:
        If .Row < 4 Then MsgBox " - Недостаточно СТРОК!" & Chr(10) & Chr(10) & _
                            "Исполнение возможно с 4-ой строки или ниже.", vbCritical + vbOKOnly, "Аварийный выход:": Set cL = Nothing: Exit Sub
        'проверяем блок ячеек, необходимый для размещения таблицы:
        flg = False
        For Each S In Range(.Offset(1), .Offset(-3, 4))
            If Len(S) Then
                flg = True
                Exit For
            End If
        Next
        If flg = True Then
            'проверяем наличие в нужном диапазоне объединенных ячеек
            fff = False
            For Each S In Range(.Offset(-3), .Offset(1, 4))
                If S.MergeCells = True Then
                    fff = True
                    Exit For
                End If
            Next
            'и если ненашли, то выделяем нужный диапазон, в противном случае
            If fff = False Then Range(.Offset(-3), .Offset(1, 4)).Select
            'ограничимся только адресом нужного диапазона в сообщении
            MsgBox " - Диапазон НЕ СВОБОДЕН!" & Chr(10) & Chr(10) & _
                   "Следует очистить диапазон: " & .Offset(-3).Address(RowAbsolute:=False, ColumnAbsolute:=False) & " : " & .Offset(1, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) & Chr(10) & _
                   "или выбрать ДРУГУЮ стартовую ячейку ...", vbCritical + vbOKOnly, "Аварийный выход:"
            cL.Select
            Set cL = Nothing
            Exit Sub
        End If
        
        'Если проверки прошли успешно, то работаем:
        With .Offset(-1)
            .FormulaR1C1 = "выс."
        End With
        With .Offset(-1, 1)
             .FormulaR1C1 = "дл."
        End With
        
        With .Offset(-1, 2)
            .FormulaR1C1 = "ДлСтороны"
        End With
        
        With .Offset(-1, 3)
            .FormulaR1C1 = "Д"
        End With
'===
        i = 0
        For i = 0 To 3
            With .Offset(-1, i)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter

                .Borders(xlDiagonalDown).LineStyle = xlNone
                .Borders(xlDiagonalUp).LineStyle = xlNone
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeTop).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlInsideVertical).LineStyle = xlNone
                .Borders(xlInsideHorizontal).LineStyle = xlNone
            End With
        Next i
'===
        With .Offset(-2)
            .FormulaR1C1 = "прг_"
        End With
        
'===
    With Range(.Offset(-2), .Offset(-2, 1))
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        
        .Merge
        
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
'===
        
        
        With .Offset(-2, 2)
            .FormulaR1C1 = "трг_"
        End With
        
        With .Offset(-2, 3)
            .FormulaR1C1 = "крг_"
        End With
'===
        i = 0
        For i = 2 To 3
            With .Offset(-2, i)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom

                .Borders(xlDiagonalDown).LineStyle = xlNone
                .Borders(xlDiagonalUp).LineStyle = xlNone
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeTop).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlInsideVertical).LineStyle = xlNone
                .Borders(xlInsideHorizontal).LineStyle = xlNone
            End With
        Next i
'===
        With .Offset(-3)
            .FormulaR1C1 = "размеры:"
        End With
'===
    With Range(.Offset(-3), .Offset(-3, 3))
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        
        .Merge
        
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
'===
        
        With .Offset(-3, 4)
            .FormulaR1C1 = "S, м2"
        End With
'===
    With Range(.Offset(-3, 4), .Offset(-1, 4))
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        
        .Merge
        
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
'===
        
        With .Offset(1, 4)
            .FormulaR1C1 = _
            "=IF(AND(RC[-4]>0,RC[-3]>0),ROUND((RC[-4]/1000)*(RC[-3]/1000),3),0)+IF(RC[-2]>0,ROUND((SQRT(3)*POWER((RC[-2]/1000),2))/4,3),0)+IF(RC[-1]>0,ROUND(3.1415926535*(POWER(RC[-1]/1000,2)/4),3),0)"
        End With
        
        i = 0
        For i = 0 To 4
            With .Offset(1, i)
                .HorizontalAlignment = xlRight
                .VerticalAlignment = xlCenter

                .Borders(xlDiagonalDown).LineStyle = xlNone
                .Borders(xlDiagonalUp).LineStyle = xlNone
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeTop).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlInsideVertical).LineStyle = xlNone
                .Borders(xlInsideHorizontal).LineStyle = xlNone
            End With
        Next i
    End With
    Set cL = Nothing
End Sub
 
Перейти    
выдает что LoadPicture не определена ...
 
#
26.09.2022 12:02:32
Доброго времени суток, друзья!

Уже голову сломал, а "оно как не работало, так и не работает". Есть код на событии Control-а в UserForm:
Код
Private Sub lbx_TipKroja_Change()
    Dim arrZnac
    Dim arrFiguraS
    Dim kwORul As Integer
    Dim nmVer As String, znacParam As String
    Dim wbThs As Workbook
    Dim wbNSI As Workbook
    Dim flg As Boolean

    znacParam = ""
    flg = True
    With Me.lbx_Kroja
        If .Text = "" Then Exit Sub
        'Me.lbx_TipRaskroja.ListIndex = -1 '- очищаем предыдущий выбор
        risNM = "Р_" & .List(.ListIndex, 2)
        znacParam = .List(.ListIndex, 4)
    End With

    'доведение параметра до формата имени файла
    If InStr(1, risNM, "/", vbTextCompare) > 0 Then
        risNM = Replace(risNM, "/", "][", , , vbTextCompare)
    End If
    '
    If InStr(1, znacParam, "][", vbTextCompare) > 0 Then
        With Me.lbx_TipKroja
            arrFiguraS = Split(.List(.ListIndex, 1), " / ", , vbTextCompare)
        End With
        arrZnac = Split(znacParam, "][", , vbTextCompare)
        znacParam = ""
    Else
        With Me.lbx_TipKroja
            onlFiguraS = .List(.ListIndex, 1)
        End With
    End If

    Set wbThs = ThisWorkbook '
    nmVer = Application.Version
    Select Case nmVer
        Case "14.0"
            Dim thWbFullName As String, nmFl As String
            thWbFullName = wbThs.FullName
            nmFl = wbThs.Name
            thWbPath = Replace(thWbFullName, "\" & nmFl, "", , , vbTextCompare)
        Case "16.0"
            thWbPath = wbThs.Path
    End Select

    flSPR = "\НСИ\Типы раскроя\" & risNM & ".jpg"

    If Dir(thWbPath & flSPR) = "" Then 'проверяем существует ли файл, по указанному пути
        flSPR = "\ЭлУпр\НеЗнаю.jpg"
        flg = False
    End If

    With Me.img_TipKroja
        .PictureSizeMode = fmPictureSizeModeZoom
        .Picture = LoadPicture(thWbPath & flSPR)
    End With

    If flg = False Then
        MsgBox "Файла нет", vbCritical + vbOKOnly, flSPR
        Exit Sub
    End If
    If usf_Plenka.tbx_KolWoRulonow.Value = "" Then Exit Sub
    If znacParam = "" Then
        For j = LBound(arrZnac) To UBound(arrZnac)
            geomFigur = arrFiguraS(j)
            
            With usf_Plenka
                Lt = .Left
                Tp = .Top + .Height + 6
                
                kwORul = CInt(.tbx_KolWoRulonow.Value)
            End With

            With usf_SborZnac
                .Caption = "Маска: " & geomFigur
                .lbl_plan.Caption = arrZnac(j)
                .lbl_planWsego.Caption = CStr(CInt(arrZnac(j)) * kwORul)
                .tbx_DateOper.Value = Format(Date, "dd.mm.yyyy")
                .Left = Lt
                .Top = Tp
                If j = UBound(arrZnac) Then
                    .Tag = 0
                Else
                    .Tag = 1
                End If
                
                .Show
            End With
        Next j
        
        Erase arrFiguraS
        Erase arrZnac
    Else
        geomFigur = onlFiguraS
        
        With usf_Plenka
            Lt = .Left
            Tp = .Top + .Height + 6
            kwORul = CInt(.tbx_KolWoRulonow.Value)
        End With

        With usf_SborZnac
            .Caption = "Маска: " & geomFigur
            .lbl_plan.Caption = znacParam
            .lbl_planWsego.Caption = CStr(CInt(znacParam) * kwORul)
            .tbx_DateOper.Value = Format(Date, "dd.mm.yyyy")
            .Left = Lt
            .Top = Tp
            .Tag = 0
            
            .Show
        End With
    End If
End Sub
и вот на строках:
Код
    With Me.img_TipKroja
        .PictureSizeMode = fmPictureSizeModeZoom
        .Picture = LoadPicture(thWbPath & flSPR)
    End With
выдает сообщение, скриншот на скрепке. Хотя в другом файле все работало. В чем проблема - непонятно (для меня). Помогите, пожалуйста.
 
Перейти    
Визуализация результатов расчета, Визуализация результатов расчета раскладки прямоугольников на лист
 
#
02.04.2021 19:52:37
Добрый день, друзья!
Есть вот такой "калькулятор" размещения на листе, формата Высота х Длинна, прямоугольников вида выс1 х длин1.

Результат расчета я изобразил в СкетчАпе но, хотелось бы чтобы подобная картинка рисовалась автоматически.

Есть идеи?
Для тех, кто решит помочь: VBA - владею. СкетчАп просто использовал как рисовалку, что бы показать чего хочу в итоге. При реализации Визуализации, хотелось бы обойтись средствами графики Excel. Но это не факт.
Изменено: Григорий Калюга - 02.04.2021 20:02:14
 
Перейти    
OLEObject и как с ними работать?
 
#
06.04.2011 15:46:43
Добрый день, друзья!  
 
Есть в Excel панелька "Элементы управления", а вот как с ними работать, не знаю! Увы? Может что посоветуете. Особенно интересуют ListBox и ComboBox. Как их использовать, вставив непосредственно в лист, а не в UserForm. Как отловить событие выбор элемента. Если есть примеры у кого реализации, может поделитесь?
 
Перейти    
Подсчет расстояния и карту маршрута из Net-а в .xls-файл. Как?
 
#
14.03.2011 09:01:57
Доброго дня друзья!  
Задал вопрос вот тут: http://forum.msexcel.ru/proekty_vba/rabota_iz_excel_s_saytom_peredacha_dannyh_i_p­riem_rezultata_rasche_marshruta-t5100.0.html, но в ответ тишина! А хотелось бы решить задачу, описанную в заголовке темы...  
 
В прикрепленном файле пример, как бы это все должно выглядеть.  
Поиском пробовал, но народ больше курсами валют озадачен. А у меня вот несколько другая тема ...
 
Перейти    
Кнопка "как в Автофильтре"
 
#
20.11.2008 13:25:41
Добрый всем день!  
Вопрос: Как в ячейку создать кнопку по виду и функционалу неотличимую от Автофильтровской?
 
Перейти    
Взаимодействие с чатом в локальной сети организации.
 
#
28.10.2008 08:38:19
Помогите профкссионалы! Оч. нужно.  
В электронную книгу расположенную на сервере, перемещаю  кодом VBA листы из другой книги.  
После чего книга - приемник закрывается с сохранением.  
Можно ли сообщение о перемещении передавать в чат локальной сети?  
Само собой передавать должна прога, а не я ручками.
 
Перейти    
Страницы: 1
Наверх