Ответы пользователя по тегу Макросы
  • Как сделать автоматический расчет даты в MS Word?

    bopoh13
    @bopoh13
    VBA, Ruby (noob), analytic
    Много действий надо сделать, поэтому часто люди заполняют руками. К тому же нужно придумать по какому событию будет производиться расчёт (или вызывать макрос из вкладки "Вид"; автоматический расчёт делают формулы в Excel).
    1. Включить в настройках вкладку "Разработчик", Режим конструктора, добавить Элементы управления (на картинке в красной рамке). Рекомендую через свойства полей указать ТЕГИ (например, dateProd, dateExp), и следить, чтобы не было разных полей с одинаковым тегом. Отключить Режим конструктора.
    2. Открыть редактор VBA (первая кнопка во вкладке "Разработчик").
    3. Создать модуль в документе. Написать функцию расчёта значения (для примера нужно прибавить 7 дней):
    Sub ShelfLife()
      '345678901234567890123456789012345bopoh13@ya67890123456789012345678toster56789
      Dim objCC As ContentControl, counter As Variant
      Dim dateProdIndex As Byte, dateExpIndex As Byte
      
      With ActiveDocument
        For Each objCC In .ContentControls
          counter = counter + 1
          Select Case objCC.Tag
            Case "dateProd": dateProdIndex = counter
            Case "dateExp": dateExpIndex = counter
          End Select
        Next objCC: Set objCC = .ContentControls(dateProdIndex)
        
        If .ContentControls(dateExpIndex).LockContents _
          Xor objCC.PlaceholderText = objCC.Range.Text Then counter = 0
        
        If dateProdIndex > 0 And dateExpIndex > 0 And counter > 0 Then
          counter = CDbl(CDate(objCC.Range.Text)) + 7
          .ContentControls(dateExpIndex).Range.Text = CDate(counter)
        Else
          MsgBox "Поле с тегом dateProd или dateExp не заполнено. " & vbCrLf _
            & "Или содержимое поля dateExp нельзя редактировать. ", vbExclamation
        End If
      End With
    End Sub
    Защита ограничения редактирования для внесения изменений в документ должна быть отключена. Можно использовать другие методы для выбора поля: по названию или тегу.
    Ответ написан
  • Не активна кнопка в excel, как найти решение?

    bopoh13
    @bopoh13
    VBA, Ruby (noob), analytic
    Есть вероятность, что не в пароле дело. Попробуйте убрать галку в меню: Рецензирование -> Доступ к книге -> Правка (вкладка) -> ☐ Разрешить изменять файл нескольким пользователям одновременно.
    Ответ написан
  • Может у кого есть или, что добавить в данный готовый макрос, чтобы сохранять в таком формате CSV?

    bopoh13
    @bopoh13
    VBA, Ruby (noob), analytic
    У меня возникает чувство, что вы воспользуетесь "единожды с нужным макросом" и забудете нажать кнопку "Отметить решением". А мне потом придётся удалять ответ, чтобы другие не сомневались в его верности.
    Sub SaveAsCSVinQuotes()
      Dim r As Range, c As Range, s As String
      '345678901234567890123456789012345bopoh13@ya67890123456789012345678toster56789
      s = Application.GetSaveAsFilename(FileFilter:="CSV файлы (*.csv), *.csv", _
        Title:="Сохранение CSV в кавычках (укажите разделитель в 1 строке SEP=" _
        & Application.International(xlListSeparator) & ")")
      If s = "False" Then Exit Sub
      Open s For Output As #1
      For Each r In ActiveSheet.UsedRange.Rows
        s = ""
        For Each c In r.Cells
          If c.Value2 Like "* *" Then s = s & ";" & """" & c & """" _
          Else s = s & ";" & c
        Next c: Print #1, Mid(s, 2)
      Next r: Close #1
    End Sub
    И не забудьте экранировать кавычки кавычками, если они будут встречаться в названии колонки.
    Ответ написан
  • Какие методы обмена информацией с удаленными объектами через excel vba существуют?

    bopoh13
    @bopoh13
    VBA, Ruby (noob), analytic
    Запрос к БД MS SQL из Excel — какой драйвер применять? - любой драйвер на выбор :)
    К таблице Excel лучше так не подключаться (нельзя чтобы файл был занят).
    Option Explicit
    '12345678901234567890123456789012345bopoh13@ya67890123456789012345678toster56789
    
    Sub TestADO()
      Dim Conn As Object, Rec As Object
      
      On Error GoTo ErrMsg ' Создание подключения через драйвер
        Set Conn = CreateObject("ADODB.Connection") ' Открываем Connection
        Conn.ConnectionTimeout = 5
        Conn.Mode = 1 ' 1 = adModeRead, 2 = adModeWrite, 3 = adModeReadWrite
        Str = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & $dbPath & ";"
        ' Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1""
        'Str = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & $dbPath & ";"
        'Str = Str & "Jet OLEDB:Engine Type=6;" ' Тип подключения (не используется)
        Str = Str & "Jet OLEDB:Encrypt Database=False;"
        Str = Str & "Jet OLEDB:Database Password=" & $passDB & ";"
        ' Системная таблица Access 2003 (файлы *.mdb) 
        'Str = Str & "Jet OLEDB:System database=" & $mdwPath
        
        Conn.Open ConnectionString:=Str ', UserId:="$admin", Password:=""
        Debug.Print "Conn.State="; Conn.State
        
        Set Rec = CreateObject("ADODB.Recordset") ' Создаём RecordSet для чтения данных
        ' ...
        Set Rec = Nothing: Set Conn = Nothing
      On Error GoTo 0: Exit Sub
      
    ErrMsg:
      MsgBox Str & String(2, vbCrLf) & "Provider=" & Conn.Provider, _
        vbOKOnly + vbCritical, "Error: " & Err.Number & ", AppVer: " _
        & Val(Application.Version): Set Rec = Nothing: Set Conn = Nothing
    End Sub
    Ответ написан
  • Как создать универсальный шаблон письма в Word'е?

    bopoh13
    @bopoh13
    VBA, Ruby (noob), analytic
    1. Можно промаркировать жёлтый текст и сделать замену прямо в Word (в примере 1 замена во всём тексте), или использовать закладки (Вставка (меню) -> Ссылки (группа) -> Закладки), или использовать инструмент Слияние и брать данные из файла Excel (без VBA). При слиянии связи могут глючить + конечный документ необходимо Объединить (как текущую запись), чтобы при работе с документом поля не обновлялись (Слияние использовать не советую). К тому же поля не поддерживают неразрывные символы Word'а Chr(160) и Chr(30).
      Option Explicit
      '12345678901234567890123456789012345bopoh13@ya67890123456789012345678toster56789
      
      Sub Replacement_tags()
        Dim Content_Find As Find ' Объект Find
        
        Set Content_Find = ActiveDocument.Content.Find
        With Content_Find ' Найти маркер
          .ClearFormatting: .Replacement.ClearFormatting ' Очистить формат
          .MatchWildcards = False ' ВАЖНО! Отключить Подстановочные знаки
          
          .Text = "[Шапка]": .Replacement.Text = "Начальнику управления..."
          .Execute Forward:=True, Replace:=wdReplaceAll ' Заменить все маркеры [Шапка]
          
          ' Хитрость: перемещение курсора в конец заменённого текста
          .Execute FindText:=.Replacement.Text, _
            Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceNone
          .Parent.Select ' Выделяем текст для управления курсором
          'Selection.Collapse Direction:=wdCollapseEnd ' Курсор в конец найденного
        End With
      End Sub
    2. Можно сразу заменить на дублированный текст:
      .Replacement.Text = "Начальнику управления..." & String(3, Chr(13)) & "Начальнику управления..."
      или вводить количество дублей в переменную Text перед заменой:
      ' Chr(13) - код символа возврата каретки. В других языках более привычная запись "\r"
      
        CapText = "Начальнику управления..."
        CapСount = InputBox("Введите количество 'Шапок'", , 1)
        If Not CInt(Val(CapСount)) = CapСount Then _
          MsgBox "Введите целое число", vbCritical: Exit Sub _
        Else Text = CapText
        
        While CapСount > 1
          Text = Text & String(3, Chr(13)) & CapText
          CapСount = CapСount - 1
        Wend
    3. Таблицу можно также подтягивать через Слияние (точнее там создаётся объект OLE, которой глючит больше чем обычные поля - в основном это удержание файла Excel, откуда берутся данные). Удобнее программно создавать таблицу:
      ' Используем хитрость из п.1, если планируем создать таблицу в месте маркера
        
        Set tblNew = ActiveDocument.Tables.Add(Selection.Range, 3, 2)
        With tblNew
          .Columns(1).PreferredWidth = CentimetersToPoints(4) ' Колонка 1, Ширина 4 см
          .Borders(wdBorderTop).LineStyle = wdLineStyleNone ' Границы таблицы, например
          .Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
          .Borders(wdBorderVertical).LineStyle = wdLineStyleDot
          For i = 1 To 2
            .Cell(1, i).Range.Text = "Строка 1; #" & i
          Next i
          .Cell(1, 1).Range.InsertAfter Chr(13) & "Строка 2" ' Добавить текст
          .Cell(tblNew.Rows.count, tblNew.Columns.count).Range.InsertAfter "Последняя ячейка"
        End With
    4. Чтобы основной текст нельзя было отредактировать, проще всего создать шаблон Word с поддержкой макросов, основную процедуру (автозапуск) разместить в модуле ThisDocument:
      Private Sub Document_Open()
        Replacement_tags ' Процедура из п.1
      End Sub
      Данные для заполнения шаблона можно поместить в отдельный файл.

    +
    Как использовать отладчик:
    1. Открыть MS Word, в тексте написать маркер [Шапка]
    2. Открыть VBA в приложении (Alt+F11)
    3. Выбирать в меню Insert -> Module
    4. Вставить процедуру (из п.1)
    5. Нажать F5 (запустится процедура, в которой установлен курсор)
    Ответ написан
  • Как исправить данную ошибку в Excel?

    bopoh13
    @bopoh13
    VBA, Ruby (noob), analytic
    Не нужно Вам использовать функцию CDate; в Excel по умолчанию даты - это числа, - хорошо складываются.
    Как написал Антон Федорян задайте тип переменной j. Без указания типа переменной получается j As Variant. Если будет возникать указанная ошибка, у Вас в колонке A попалось "не число". Примечание: Типы данных.
    Ответ написан
  • Написание макросов Excel, какой скилл нужен?

    bopoh13
    @bopoh13
    VBA, Ruby (noob), analytic
    Как и в других высокоуровневых языках:
    1. Понимание основ программирования (переменные/операторы/логические операции/циклы)
    2. Понимание объектной структуры
    3. Понимание поставленной задачи

    Если есть время читайте книги "Книги, методички для изучения VBA с нуля?", если нет - ищите решение задачи в и-нете. Серьёзные задачи макрорекодор выполнять в принципе не может, - он не программист.
    Ответ написан
  • Как объединить ячейки с одинаковыми значениями в Excel с помощью VBA?

    bopoh13
    @bopoh13
    VBA, Ruby (noob), analytic
    Option Explicit
    Option Base 1
    '12345678901234567890123456789012345bopoh13@ya67890123456789012345678toster56789
    
    Sub Merge_by_Rows() ' Без форматирования границ
      Dim i As Integer, j As Integer, cnt As Integer
      Dim arr() As Variant, s As String
      
      With ActiveSheet.UsedRange ' Кол-во столбцов определяется по 1-й строке
        arr = Range(Cells(1, 1), Cells(.Rows.Count + 1, Range("A1").End(xlToRight).Column))
      End With
      
      cnt = 1: s = get_Row(arr, cnt)
      For i = LBound(arr, 1) + 1 To UBound(arr, 1)
        If get_Row(arr, i) <> s Then
          For j = LBound(arr, 2) To UBound(arr, 2)
            With ActiveSheet.Range(Cells(cnt, j), Cells(i - 1, j)).Offset(, UBound(arr, 2))
              .Merge
              .HorizontalAlignment = xlCenter
              .VerticalAlignment = xlCenter
              .Value = arr(cnt, j)
            End With
          Next j
          cnt = i: s = get_Row(arr, cnt)
        End If
      Next i
    End Sub
    
    Function get_Row(ByVal arr As Variant, ByVal num_Row As Integer) As String
      Dim j As Integer
      
      For j = LBound(arr, 2) To UBound(arr, 2)
        get_Row = WorksheetFunction.Trim(get_Row & " " & arr(num_Row, j))
      Next j
    End Function

    Процедуру выполнять на активном листе.
    Ответ написан
  • Почему не работает отображение критериев автофильтра через пользовательскую функцию при его включении из VBA?

    bopoh13
    @bopoh13
    VBA, Ruby (noob), analytic
    Советую отказаться от пользовательских функций ;) Читаем критерии фильтров на текущем листе для одного (последнего) поля в ячейку J7. Удобно, если критерий указан в единственном поле:
    Dim Str As String
    
    For Each filt In ActiveSheet.AutoFilter.Filters
      If filt.On Then _
        If CByte(filt.Operator) = 0 Then Str = filt.Criteria1 _
        Else Str = filt.Criteria1 & IIf(CByte(filt.Operator) = 1, " AND ", " OR ") & filt.Criteria2
    Next filt: ActiveSheet.Range("J7") = Str

    Данные таблицы начинаются с 10 строки, так что тут все правильно

    Здесь проблема более эзотерического свойства. Все-таки в большинстве случаев эта пользовательская функция таки работает, как видно на скрине (показывает критерий отбора для столбца J). Нот вот если тот же самый критерий отбора я задаю не вручную, а через vba - все, пусто...

    Это должно работать для передачи критерия фильтру:
    ActiveSheet.Range("$A$9:$P$1115").AutoFilter Field:=10, Criteria1:="<>0"
    Ответ написан
  • Существует ли способ написать макрос для Excel, который будет следить за буфером обмена?

    bopoh13
    @bopoh13
    VBA, Ruby (noob), analytic
    Макросы MS Office работают только в рамках приложения. В VBA есть функции по работе с буфером, но только основные. Описание с примерами:
    www.cyberforum.ru/vba/thread844325.html
    excelvba.ru/code/clipboard
    wordexpert.ru/page/principy-raboty-s-buferom-obmen...
    hiprog.com/index.php?id=350&option=com_content&tas...
    Если функционал вам не подходит, нужно искать другие способы решения задачи.
    Ответ написан
  • Как перейти на новую строку после заполнения предыдущей EXCEL VBA?

    bopoh13
    @bopoh13
    VBA, Ruby (noob), analytic
    Во первых, чтобы не копировать иероглифы, нужно в окне с кодом переключиться на русский язык.
    Во вторых, в данном случае вместо Application лучше написать WorksheetFunction.
    В третьих, у вас в коде написано:
    ' НомерСтроки - Кол-во непустых ячеек в колонке "1" + 1, а не номер первой пустой строки

    Если в 1-й колонке таблицы есть хотя бы одна пустая строка, то намерения вставить новую запись в конец таблицы будут не выполнены. Поэтому замените на:
    ' НомерСтроки - Номер первой пустой строки на рабочем листе
    НомерСтроки = ActiveSheet.Cells.SpecialCells(xlLastCell).Row + 1


    UPD: Количество непустых ячеек (при их наличии) к колонке активной ячейки можно посчитать:
    КолНепустых = ActiveCell.SpecialCells(xlCellTypeLastCell).Row - _
      ActiveCell.EntireColumn.SpecialCells(xlCellTypeBlanks).Count
    Ответ написан
  • Excel VBA почему не выполняется поиск в объединенных ячейках?

    bopoh13
    @bopoh13
    VBA, Ruby (noob), analytic
    Замените SearchOrder:=xlByColumns на SearchOrder:=xlByRows
    и удалите строки Cells.FindNext(After:=ActiveCell).Activate
    Ответ написан
  • Как разделить .xlsx по строкам?

    bopoh13
    @bopoh13
    VBA, Ruby (noob), analytic
    Если файл сохранён на диске, можно так:
    1. Открываете книгу с данными на нужном листе
    2. Заходите в VBA (Alt+F11)
    3. Выбираете в меню Insert -> Module
    4. Вставляете нижеприведённый код
    5. Нажимаете F5 (не сохраняете исходный файл)

    Option Explicit ' Обязательное объявление переменных
    Option Base 1 ' Нижняя граница массива (по умолчанию)
    '12345678901234567890123456789012345bopoh13@ya67890123456789012345678toster56789
    
    Sub Border_Limit()
      Dim Limit As Integer, Count As Integer, SaveDir As String, SetTitle As Boolean
      
      Count = 1: Limit = 1000 ' Счётчик файлов; Количество строк
      SetTitle = False ' Если есть заголовок, заменить False на True
      
      SaveDir = ThisWorkbook.Path ' Или вписать полный путь для сохранения "C:\"
      ' Предполагается, что в колонке A нет пустых ячеек
      While Not IsEmpty(Cells(IIf(SetTitle, 2, 1), 1))
        Rows("1:" & Limit).Copy
        Workbooks.Add xlWBATWorksheet ' Создать новую книгу: шаблон с 1 листом
        ActiveSheet.Paste: Cells(1, 1).Select
        ActiveWorkbook.SaveAs Filename:=SaveDir & "\Массив_" & Count & ".xlsx", _
          FileFormat:=xlOpenXMLWorkbook
        ActiveWindow.Close
        Rows(IIf(SetTitle, 2, 1) & ":" & Limit).Delete Shift:=xlUp
        Count = Count + 1
      Wend: MsgBox "Файл разбит на " & Count - 1 & " файл(ов). "
    End Sub

    Никакие C++ запускать не надо.

    Для пытливых умов: Отказ от Слияния в пользу шаблонов https://toster.ru/q/320942
    Ответ написан
  • Как отправить email с вложение из Outlook с помощью VBA?

    bopoh13
    @bopoh13
    VBA, Ruby (noob), analytic
    Макрос отправляет письмо на "Место события" при появлении оповещения о событии.

    ' Процедуру разместить в модуле ThisOutlookSession.
    ' Уровень безопасности макросов (без цифровой подписи) - низкая.
    Option Explicit
    '12345678901234567890123456789012345bopoh13@ya67890123456789012345678toster56789
    
    Private Sub Application_Reminder(ByVal Item As Object)
      Dim objMsg As MailItem, sAttachment As String
      Set objMsg = Application.CreateItem(olMailItem)
      
      ' Путь к файлу вложения (Указанный файл "Текст.txt" находится на Рабочем столе)
      sAttachment = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & "\Текст.txt"
      
      If Item.MessageClass <> "IPM.Appointment" Then
        Exit Sub
      End If
      If Item.Categories <> "Automated Email Sender" Then
        Exit Sub ' Закомментировать, если у события не указана категория
      End If
      
      With objMsg
        .To = Item.Location ' Место события
        .Subject = Item.Subject
        .Body = Item.Body
        ' Если файл вложения существует, то добавить в письмо
        If Len(sAttachment) > 0 Then .Attachments.Add sAttachment
        '.Display '' Показать письмо (для отправки вручную; вместо '.Send)
        .Send
      End With: Set objMsg = Nothing
    End Sub

    Заметка: Могут быть проблемы при создании писем по просроченным событиям.
    Ответ написан
  • Как записать и использовать такой макрос в Excel?

    bopoh13
    @bopoh13
    VBA, Ruby (noob), analytic
    Очевидно, формула, которую надо размножить, записана во "второй строчке", т.е. диапазоне H3:K3.
    Вставьте нижеприведённый код в Module1 (который указан на скриншоте).

    ' Не самый оптимальный, но наглядный способ. Ctrl+Break - экстренная остановка.
    Option Explicit
    '12345678901234567890123456789012345bopoh13@ya67890123456789012345678toster56789
    
    Sub Макрос1()
      Dim i As Long
      
      i = 3 ' Формулу будем копировать с 3-й строки
      With ThisWorkbook.ActiveSheet
        Do
          i = i + 1
          .Range("H" & i & ":K" & i) = .Range("H" & i - 1 & ":K" & i - 1).FormulaR1C1
        Loop Until i = .UsedRange.Rows.Count ' Цикл ДО последней строки с данными
      End With
    End Sub
    Ответ написан