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

Страницы: 1 2 3 4 След.
Определить лучшие по разнице в марже объемы отгрузок
 
#
12.05.2021 17:44:55
Цитата
MCH написал:
Но по описанию может быть задачу можно решить жадным алгоритмом, отсортировав варианты по доходности, наилучшей меду собственной маржинальностью и сторонней
Я посмотрел все ссылки и файлы на других форумах, в том числе, и ваши наработки.
У меня мозга не хватит переделать ваш макрос под эти условия. ((
Может, у вас найдет время и желание?  
 
Перейти    
Определить лучшие по разнице в марже объемы отгрузок
 
#
09.05.2021 00:12:18
Насколько я помню из своего небольшого опыта, Поиск решения ограничен в количестве вариантов. А станций, одномоментно, может быть около двухсот.
 
Перейти    
Определить лучшие по разнице в марже объемы отгрузок
 
#
08.05.2021 20:58:12
Я же написал формулу, которая решает задачу. Просто, она трехэтажная и, скажем так, промежуточная. Может,  у кого хватит талантов и знаний, ее оптимизировать и прикрутить суммирование.
 
Перейти    
Определить лучшие по разнице в марже объемы отгрузок
 
#
08.05.2021 12:18:13
Реальный объем отгрузки, из реального отчета.
Объем отгрузки я взял, чтобы проще было формулу писать.
Маржа 1 - маржа нашего предприятия
Маржа 2- маржа от перепродажи продукции других предприятий.
Разница между этими значениями бывает такая, что выгоднее закупить продукцию у других.
Это и должна показывать формула

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

Если есть вариант формулой, буду очень признателен.
 
Перейти    
Определить лучшие по разнице в марже объемы отгрузок
 
#
07.05.2021 17:26:38
Пока ничего умнее трехэтажной формулы не придумал. Может, кто-то подскажет, как оптимизировать ее? И забрать в одну суммовую ячейку (помечены цветом), пока, тоже не получается.
 
Перейти    
Определить лучшие по разнице в марже объемы отгрузок
 
#
07.05.2021 11:59:38
Добрый день.
В отчете есть необходимость определить сколько и какие варианты отгрузок оставить в зависимости от ограничения по объему.

Дело в том, что если оставить за своим предприятием объемы лучшие по марже, доходность выходит меньше, чем, если оставить объемы, лучшие по разнице в марже между своим предприятием и предприятиями, у которых можно дополнительно закупить эту же продукцию.

Для сравнимости я выставил одинаковые объемы.

Проблема в том, что простое суммирование не помогает, если менять сортировку.
Можно ли как то реализоваться формулой (ну, или макросом), которая выделит без сортировки лучшие по разнице в марже объемы приблизительно на общий объем ограничения (в данном случае 50 000 тн для модели или 20000 тн, если брать реальные объемы из столбца В?
 
Перейти    
Выбор всех значений из списка по условию при помощи макроса, а не формулы, многоразовый ВПР
 
#
02.05.2021 14:04:34
У этой моей задачи есть, еще одна составляющая.

Второй итерацией необходимо вернуть объемы на лист с данными, но, уже перераспределив по другим предприятиям (а, может, и оставить на первоначальном предприятии).

Формула (я ее вставил), конечно, делает это, но где формула и 10 000 строк и более, там и торможение всего процесса пересчета.

Можно ли, по нажатию кнопки, макросом вернуть данные в конкретные ячейки по условию названия станции и выбранного для этого объема и станции предприятия, не забивая данные во всем диапазоне?

PS. Уважаемые модераторы, есть ли необходимость под это создавать отдельную тему?
 
Перейти    
Выбор всех значений из списка по условию при помощи макроса, а не формулы, многоразовый ВПР
 
#
02.05.2021 12:12:43
А, подскажите, если не сложно, еще один момент.

Когда выбираю предприятие у которого нет объемов, макрос начинает ругаться на эту строчку:
Код
ReDim ARR2(1 To Application.WorksheetFunction.CountIfs(sh.Columns(25), ">0", sh.Columns(4), sh2.Cells(3, 2)), 1 To 2)
Пишет, что Subscript out of range.
Чего ему не хватает?
 
Перейти    
Выбор всех значений из списка по условию при помощи макроса, а не формулы, многоразовый ВПР
 
#
02.05.2021 11:54:32
Я имел в виду, вариант, когда, вообще все пять станций вытаскиваются, а не только станции с ненулевыми объемами.

Вставляю код в файл. Заменяю на свои листы, строки, столбцы. Код начинает ругаться на K. Пишет, что переменная не определена.
Могу я определить ее как Variant и все?
Код
Sub Станции()
Dim ARR, ARR2, i As Long, lr As Long
Dim sh As Worksheet, sh2 As Worksheet
Set sh = Worksheets("СтанцииТарифы"): Set sh2 = Worksheets("РасчетыЛюбойЗавод)
lr = sh.Cells(Rows.Count, 3).End(xlUp).Row
ARR = sh.Range("A2:Y" & lr)
ReDim ARR2(1 To Application.WorksheetFunction.CountIfs(sh.Columns(25), ">0", sh.Columns(4), sh2.Cells(3, 2)), 1 To 2): K = 1
For i = LBound(ARR) To UBound(ARR)
    If ARR(i, 25) > 0 And sh2.Cells(3, 2) = ARR(i, 4) Then ARR2(K, 1) = ARR(i, 2): ARR2(K, 2) = ARR(i, 4): K = K + 1
Next i
sh2.Range("B14:E161").ClearContents
sh2.Range("B14").Resize(UBound(ARR2), 4) = ARR2
End Sub
 
Перейти    
Выбор всех значений из списка по условию при помощи макроса, а не формулы, многоразовый ВПР
 
#
01.05.2021 21:03:26
Mershik, спасибо. Как сделать макрос без условия не нулевых объемов я сообразил. ))
Большое спасибо.
 
Перейти    
Выбор всех значений из списка по условию при помощи макроса, а не формулы, многоразовый ВПР
 
#
01.05.2021 20:27:26
Добрый день.
В отчетном файле есть необходимость забирать из списка размером более 10 000 строк данные о станциях по условию выбора из выпадающего списка предприятия.
На данный момент это происходит при помощи формулы массива. Как вы понимаете, с быстродействием все очень грустно, при том, что сам файл заточен на кучу задач.
Есть ли возможность вытащить необходимую информацию на другой лист макросом? И как вариант, вытащить не все станции, а только станции с не пустыми значениями больше ноля?
 
Перейти    
Оптимизация распределения объемов. Вероятно, лучше макросом.
 
#
08.03.2021 18:47:04
Добрый день.
На работе подкинули задачу оптимального распределения объемов отгрузки.
Я сделал формулой, но, поскольку формула перебирает 12 000 строк, ждать, когда она закончит пересчитывать любое изменение, это за гранью добра и зла.
Пытался прикрутить поиск решения, но он имеет ограничение, а у меня точек доставки более 300.

Кто возьмется предложить делать это упражнение макросом, чтобы модель, хотя бы при любом изменении параметров не начинала пересчитываться и виснуть.

С уважением,
Олег
 
Перейти    
Подсчет количества уникальных записей в 4 столбцах
 
#
11.11.2019 12:08:34
Добрый день.
Как подсчитать количество уникальных записей в одном столбце, это понятно.

А, есть варианты, как подсчитать количество уникальных записей, одновременно в четырех столбцах?

С уважением,
Олег
 
Перейти    
Выделение из пофамильного списка значения в алфавитном порядке по двум условиям
 
#
10.11.2019 14:19:15
Добрый день.
Помогите, пожалуйста со сложносочиненной формулой.
Есть таблица данных со списком ФИО сотрудников по вертикале и номерами процессов, в которых они участвуют, по горизонтали. Нужно формулой перенести на другой лист в алфавитном порядке сотрудников по условию участия в процессах (до 4 возможных одновременно). Сотрудник может участвовать в одном, а может в четырех процессах, но в список они должны попасть один.

Файл с примером во вложении.
Если я некорректно объяснил, напишите.

Заранее спасибо.
С уважением,
Олег
 
Перейти    
Перенос информации из нескольких документов Word в один, оптимизация макроса
 
#
08.11.2019 13:14:15

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

С уважением,
Олег

Код
Sub Êíîïêà1_Ùåë÷îê()    Dim ICell As Range, FR As Long, Kriteriy As String
    Dim objWrdApp As Object
    Dim objWrdDoc As Object
    Dim objWrdDoc1 As Object
           
    On Error Resume Next
    
    If MsgBox("Âû, äåéñòâèòåëüíî, õîòèòå îáíîâèòü, èìåííî, ýòó Ðîëåâóþ Èíñòðóêöèþ?", vbYesNo + 32, "Âûø âûáîð?") = vbYes Then
    
    Set objWrdApp = GetObject(, "Word.Application")
    If objWrdApp Is Nothing Then
        Set objWrdApp = CreateObject("Word.Application")
        Set objWrdDoc = objWrdApp.Documents.Open(ThisWorkbook.Path & "\ÐÈ\Øàáëîí_Ðîëåâàÿ_Èíñòðóêöèÿ_ïîëüçîâàòåëÿ.docx")
            objWrdApp.Visible = True
    End If
    Application.ScreenUpdating = False
    Kriteriy = Range("D1")
    Sheets(6).Cells.Clear
    Range(Cells(2, 3), Cells(2, 5)).Copy Sheets(6).Cells(1, 1)
    Cells(2, 9).Copy Sheets(6).Cells(1, 4)
    FR = 2
    For Each ICell In Range(Cells(3, "J"), Cells(Rows.Count, "J").End(xlUp))
       If ICell Like Kriteriy & "*" Then
          Range(Cells(ICell.Row, 3), Cells(ICell.Row, 5)).Copy
          Sheets(6).Cells(FR, 1).PasteSpecial Paste:=xlPasteValues
          Sheets(6).Cells(FR, 1).PasteSpecial Paste:=xlPasteFormats
          Range(Cells(ICell.Row, 9), Cells(ICell.Row, 10)).Copy
          Sheets(6).Cells(FR, 4).PasteSpecial Paste:=xlPasteValues
          Sheets(6).Cells(FR, 4).PasteSpecial Paste:=xlPasteFormats
          FR = FR + 1
       End If
    Next
 
    Set objWrdDoc = objWrdApp.Documents.Open(ThisWorkbook.Path & "\ÐÈ\Øàáëîí_Ðîëåâàÿ_Èíñòðóêöèÿ_ïîëüçîâàòåëÿ.docx")
        objWrdDoc.Bookmarks("ÁèçíåñÐîëü").Range.InsertAfter (Cells(1, 4).Value)
        objWrdDoc.Bookmarks("ÁèçíåñÐîëü1").Range.InsertAfter (Cells(1, 4).Value)
        
        objWrdDoc.Bookmarks("ÒðàíçÀê1").Range.InsertAfter (Sheets(4).Cells(25, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(25, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(25, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê1òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        'Selection.InsertFile "e:\test.docx" ' âñòàâêà èç ôàéëà test.docx áåç åãî îòêðûòèÿ â òåêóùóþ ïîçèöèþ
        objWrdDoc.Bookmarks("ÒðàíçÀê2").Range.InsertAfter (Sheets(4).Cells(26, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(26, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(26, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê2òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê3").Range.InsertAfter (Sheets(4).Cells(27, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(27, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(27, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê3òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê4").Range.InsertAfter (Sheets(4).Cells(28, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(28, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(28, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê4òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê5").Range.InsertAfter (Sheets(4).Cells(29, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(29, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(29, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê5òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê6").Range.InsertAfter (Sheets(4).Cells(30, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(30, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(30, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê6òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê7").Range.InsertAfter (Sheets(4).Cells(31, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(31, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(31, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê7òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê8").Range.InsertAfter (Sheets(4).Cells(32, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(32, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(32, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê8òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê9").Range.InsertAfter (Sheets(4).Cells(33, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(33, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(33, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê9òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê10").Range.InsertAfter (Sheets(4).Cells(34, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(34, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(34, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê10òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê11").Range.InsertAfter (Sheets(4).Cells(35, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(35, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(35, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê11òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê12").Range.InsertAfter (Sheets(4).Cells(36, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(36, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(36, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê12òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê13").Range.InsertAfter (Sheets(4).Cells(37, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(37, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(37, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê13òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê14").Range.InsertAfter (Sheets(4).Cells(38, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(38, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(38, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê14òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê15").Range.InsertAfter (Sheets(4).Cells(39, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(39, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(39, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê15òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê16").Range.InsertAfter (Sheets(4).Cells(40, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(40, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(40, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê16òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê17").Range.InsertAfter (Sheets(4).Cells(41, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(41, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(41, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê17òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê18").Range.InsertAfter (Sheets(4).Cells(42, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(42, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(42, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê18òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê19").Range.InsertAfter (Sheets(4).Cells(43, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(43, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(43, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê19òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê20").Range.InsertAfter (Sheets(4).Cells(44, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(44, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(44, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê20òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê21").Range.InsertAfter (Sheets(4).Cells(45, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(45, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(45, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê21òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê22").Range.InsertAfter (Sheets(4).Cells(46, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(46, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(46, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê22òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê23").Range.InsertAfter (Sheets(4).Cells(47, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(47, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(47, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê23òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê24").Range.InsertAfter (Sheets(4).Cells(48, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(48, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(48, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê24òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        objWrdDoc.Bookmarks("ÒðàíçÀê25").Range.InsertAfter (Sheets(4).Cells(49, 4).Value)
        If Dir(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(49, 4).Value + ".docx") <> "" Then
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Òðàíçàêöèè\" + Sheets(4).Cells(49, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÍà÷àëî").Start, End:=objWrdDoc1.Bookmarks("ÒðàíçÀêÒåêñòÊîíåö").Start - 1).Copy
        objWrdDoc.Bookmarks("ÒðàíçÀê25òåêñò").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        End If
        
        Sheets(6).Range("A1:D" & Cells(Rows.Count, 1).End(xlUp).Row).Copy
        objWrdDoc.Bookmarks("Áèçíåñ_ôóíêöèè_Ðîëè").Range.PasteAndFormat (wdFormatOriginalFormatting)
        
        Const wdHeaderFooterPrimary = 1
        For Each objSection In objWrdDoc.Sections
        If objSection.Index > 1 Then objSection.Headers(wdHeaderFooterPrimary).Range.Cells(1).Range.Text = "Èíñòðóêöèÿ ïîëüçîâàòåëÿ " + Range("D1")
        Next
  
        objWrdDoc.TablesOfContents(1).Update
        objWrdDoc.SaveAs (ThisWorkbook.Path & "\ÐÈ\173_1.2.1.2.0-XX_" + Range("D1") + "_" + Format(Date, "dd/mm/yyyy") + ".docx")
        Application.ScreenUpdating = True
        Application.CutCopyMode = False
        
    Set objWrdDoc = Nothing
   'Set objWrdDoc1 = Nothing
    Set objWrdApp = Nothing
   End If
End Sub
 
Перейти    
Перенос информации из нескольких документов Word в один, оптимизация макроса
 
#
08.11.2019 11:20:11
Я интуитивно чувствую, что, что-то подобное нужно прикрутить, только у меня, пока, соображения не хватает. ))


Код
Sub ïðèìåð1()
Dim sht As Worksheet
Dim i As Integer
Dim k As Integer
For Each sht In 
ActiveWorkbook.Worksheets
    For i = 1 To sht.Cells(Rows.Count, 3).End(xlUp).Row
        If 
sht.Cells(i, 3) = "Slovo" 
Then
            k = k + 1
            Exit For
        End If
    Next i
Next sht
End Sub
 
Перейти    
Перенос информации из нескольких документов Word в один, оптимизация макроса
 
#
08.11.2019 10:45:38
Вопрос с Msgbox отпал. Я сам разобрался. ))
Код
If MsgBox("Вы, действительно, хотите обновить, именно, эту Ролевую Инструкцию?", vbYesNo + 32, "Выш выбор?") = vbYes Then

End If
 
Перейти    
Перенос информации из нескольких документов Word в один, оптимизация макроса
 
#
08.11.2019 09:58:15
Добрый день.

Знающие люди, помогите, пожалуйста, оптимизировать код в макросе. Сам то я ни разу не программист ))
Что смог, я в макросе собрал. Он рабочий. Но есть проблема, которая (надеюсь, пока) выше моего разумения.

Засунуть все повторяющиеся действия с открытием файлов Word и копированием данных в шаблон в цикл, который будет проверять наличие в папке файла с соответствующим ячейке названием и если его нет, переходить к следующей ячейке.

Сам файл тяжелый да еще и связан с текстовыми файлами, поэтому вкладываю, только, код.
Заранее спасибо.
Код
Sub Кнопка1_Щелчок()    Dim ICell As Range, FR As Long, Kriteriy As String
    Dim objWrdApp As Object
    Dim objWrdDoc As Object
    Dim objWrdDoc1 As Object
    
    On Error Resume Next
    Set objWrdApp = GetObject(, "Word.Application")
    If objWrdApp Is Nothing Then
        Set objWrdApp = CreateObject("Word.Application")
        Set objWrdDoc = objWrdApp.Documents.Open(ThisWorkbook.Path & "\РИ\Шаблон_Ролевая_Инструкция_пользователя.docx")
            objWrdApp.Visible = True
    End If
    Application.ScreenUpdating = False
    Kriteriy = Range("D1")
    Sheets(6).Cells.Clear
    Range(Cells(2, 3), Cells(2, 5)).Copy Sheets(6).Cells(1, 1)
    Cells(2, 9).Copy Sheets(6).Cells(1, 4)
    FR = 2
    For Each ICell In Range(Cells(3, "J"), Cells(Rows.Count, "J").End(xlUp))
       If ICell Like Kriteriy & "*" Then
          Range(Cells(ICell.Row, 3), Cells(ICell.Row, 5)).Copy
          Sheets(6).Cells(FR, 1).PasteSpecial Paste:=xlPasteValues
          Sheets(6).Cells(FR, 1).PasteSpecial Paste:=xlPasteFormats
          Range(Cells(ICell.Row, 9), Cells(ICell.Row, 10)).Copy
          Sheets(6).Cells(FR, 4).PasteSpecial Paste:=xlPasteValues
          Sheets(6).Cells(FR, 4).PasteSpecial Paste:=xlPasteFormats
          FR = FR + 1
       End If
    Next
 
    Set objWrdDoc = objWrdApp.Documents.Open(ThisWorkbook.Path & "\РИ\Шаблон_Ролевая_Инструкция_пользователя.docx")
        objWrdDoc.Bookmarks("БизнесРоль").Range.InsertAfter (Cells(1, 4).Value)
        objWrdDoc.Bookmarks("БизнесРоль1").Range.InsertAfter (Cells(1, 4).Value)
        
        objWrdDoc.Bookmarks("ТранзАк1").Range.InsertAfter (Sheets(4).Cells(25, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(25, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк1текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк2").Range.InsertAfter (Sheets(4).Cells(26, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(26, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк2текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк3").Range.InsertAfter (Sheets(4).Cells(27, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(27, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк3текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк4").Range.InsertAfter (Sheets(4).Cells(28, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(28, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк4текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк5").Range.InsertAfter (Sheets(4).Cells(29, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(29, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк5текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк6").Range.InsertAfter (Sheets(4).Cells(30, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(30, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк6текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк7").Range.InsertAfter (Sheets(4).Cells(31, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(31, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк7текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк8").Range.InsertAfter (Sheets(4).Cells(32, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(32, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк8текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк9").Range.InsertAfter (Sheets(4).Cells(33, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(33, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк9текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк10").Range.InsertAfter (Sheets(4).Cells(34, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(34, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк10текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк11").Range.InsertAfter (Sheets(4).Cells(35, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(35, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк11текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк12").Range.InsertAfter (Sheets(4).Cells(36, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(36, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк12текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк13").Range.InsertAfter (Sheets(4).Cells(37, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(37, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк13текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк14").Range.InsertAfter (Sheets(4).Cells(38, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(38, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк14текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк15").Range.InsertAfter (Sheets(4).Cells(39, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(39, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк15текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк16").Range.InsertAfter (Sheets(4).Cells(40, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(40, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк16текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк17").Range.InsertAfter (Sheets(4).Cells(41, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(41, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк17текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк18").Range.InsertAfter (Sheets(4).Cells(42, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(42, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк18текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк19").Range.InsertAfter (Sheets(4).Cells(43, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(43, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк19текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк20").Range.InsertAfter (Sheets(4).Cells(44, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(44, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк20текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк21").Range.InsertAfter (Sheets(4).Cells(45, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(45, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк21текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк22").Range.InsertAfter (Sheets(4).Cells(46, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(46, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк22текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк23").Range.InsertAfter (Sheets(4).Cells(47, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(47, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк23текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк24").Range.InsertAfter (Sheets(4).Cells(48, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(48, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк24текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        objWrdDoc.Bookmarks("ТранзАк25").Range.InsertAfter (Sheets(4).Cells(49, 4).Value)
    Set objWrdDoc1 = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Транзакции\" + Sheets(4).Cells(49, 4).Value + ".docx")
        objWrdDoc1.Range(Start:=objWrdDoc1.Bookmarks("ТранзАкТекстНачало").Start, End:=objWrdDoc1.Bookmarks("ТранзАкТекстКонец").Start - 1).Copy
        objWrdDoc.Bookmarks("ТранзАк25текст").Range.PasteAndFormat (wdFormatOriginalFormatting)
        objWrdDoc1.Close SaveChanges:=False
        
        Sheets(6).Range("A1:D" & Cells(Rows.Count, 1).End(xlUp).Row).Copy
        objWrdDoc.Bookmarks("Бизнес_функции_Роли").Range.PasteAndFormat (wdFormatOriginalFormatting)
        
        Const wdHeaderFooterPrimary = 1
        For Each objSection In objWrdDoc.Sections
        If objSection.Index > 1 Then objSection.Headers(wdHeaderFooterPrimary).Range.Cells(1).Range.Text = "Инструкция пользователя " + Range("D1")
        Next
  
        objWrdDoc.TablesOfContents(1).Update
        objWrdDoc.SaveAs (ThisWorkbook.Path & "\РИ\173_1.2.1.2.0-XX_" + Range("D1") + "_" + Format(Date, "dd/mm/yyyy") + ".docx")
        Application.ScreenUpdating = True
        Application.CutCopyMode = False
        
    Set objWrdDoc = Nothing
   'Set objWrdDoc1 = Nothing
    Set objWrdApp = Nothing
    
End Sub
С уважением,
Олег
 
Перейти    
Запрет на ввод информации в ячейку по условию
 
#
10.09.2019 13:14:46
Цитата
IKor написал:
У меня возникает странное ощущение того, что мои сообщения добавляются на форум с задержкой...
Действительно, когда я отвечал, второго сообщения у меня не отражалось.
 
Перейти    
Запрет на ввод информации в ячейку по условию
 
#
10.09.2019 11:52:31
Цитата
IKor написал:
В любом случае, насколько я понимаю, одной из стоящих перед Вами задач, является определение кода позиции, соответствующего активной/выбранной услуге. Попробуйте использовать такую формулу для ячейки E9
Спасибо. В принципе, если задействовать дополнительный служебный столбец и включить в условие наличие в этом столбце буквы F, все работает.
Если, у кого-нибудь возникнет идея обойтись без дополнительного столбца, буду благодарен.
 
Перейти    
Запрет на ввод информации в ячейку по условию
 
#
10.09.2019 11:41:25
Цитата
Wiss написал:
Защита ячеек от внесения данных делается не формулами, а установкой защиты на ячейку + на лист.
Если Вы откроете вложенный файл, то убедитесь, что в ячейки напротив заголовков и позиций вставить ничего нельзя, так как на вкладке данные в проверку данных формулой внесено условие при котором ввод в ячейку разрешен, только, по условию, что в ячейке столбца А внесено значение Услуга. Мне эту формулу в проверке данных и нужно дополнить условием, описанным в начале темы.
 
Перейти    
Запрет на ввод информации в ячейку по условию
 
#
10.09.2019 10:59:09
Добрый день.

Подскажите, пожалуйста, как можно описать формулу запрета внесения информации в ячейку напротив Услуг, вставляемую в проверку данных, при том, что условие внесения (буква F), находится в ячейке выше в другом столбце, напротив Позиций.

С уважением,
Олег
 
Перейти    
Выбор из выпадающего списка через фильтрацию позиций макросом
 
#
09.09.2019 15:50:27
Добрый день.

Во вложении файл с отличным вариантом выбора значений из больших списков посредством фильтрации.
Одна проблема, работает только для двух столбцов.
Начинаю добавлять условия выбора для третьего столбца (или больше) начинает ругаться.
Подскажите, пожалуйста, что нужно добавить в коде, чтобы можно было количество столбцов с возможностью выбора из фильтрующегося списка увеличить?

С уважением,
Олег
 
Перейти    
Определение номера позиции в динамической таблице
 
#
09.09.2019 14:08:45
Цитата
Сергей написал:
с допстолбцом если нужна отельная нумерация в разных столбцах то формулу разделить
Сергей, спасибо.
Только, почему то, одной услуге, формула присваивает 50, а должна заново 10.
 
Перейти    
Определение номера позиции в динамической таблице
 
#
09.09.2019 13:50:57
Игорь, спасибо за вариант с макросом. Я извиняюсь, наверное, забыл уточнить, что предполагалось решить проблему при помощи формулы.
 
Перейти    
Определение номера позиции в динамической таблице
 
#
09.09.2019 13:45:28
Цитата
Mershik написал:
grand68 , а приложите с нормальными данными пример как есть...похожее потому что у вас всегда разный же заголовок и услуга разная?
Я приложил пример, как есть, просто без названий позиций и услуг. Первый столбец именно стандартным выпадающим списком определяет, что, далее по таблице будет заполняться, Заголовок, Позиция или Услуга.
 
Перейти    
Определение номера позиции в динамической таблице
 
#
09.09.2019 13:28:13
Добрый день. Можно ли, каким-то образом изощриться и организовать присвоение позиции строки с шагом 10 (10; 20; 30 и т.д.)
Проблема в том, что иерархию и количество позиций формируют произвольно выпадающим списком в столбце А. Во вложенном файле пример, как должны быть присвоены номера, в зависимости от представленной иерархии.

С уважением,
Олег
 
Перейти    
Замена текста в ячейке таблицы в колонтитуле документа ворд значением из ячейки эксель макросом из эксель
 
#
06.09.2019 14:41:53
Цитата
БМВ написал:
У вас несколько секций в документе можно проще, для второй секции например
Для второй, понятно. А для всех, кроме первой?
 
Перейти    
Замена текста в ячейке таблицы в колонтитуле документа ворд значением из ячейки эксель макросом из эксель
 
#
06.09.2019 13:34:41
Цитата
БМВ написал:
grand68 , Думаю, немного обезличенный файл "Шаблон_инструкция пользователя.docx", да и Excel файл были б не лишними.
Добавил файлы
 
Перейти    
Замена текста в ячейке таблицы в колонтитуле документа ворд значением из ячейки эксель макросом из эксель
 
#
06.09.2019 12:04:21

Добрый день.
Название темы, немного, длинное, но отражает суть проблемы.
На просторах интернета достаточно информации как обратиться к верхнему не первому колонтитулу документа ворд из эксель. Но как я не пытался, у меня не получается добавить замену именно теста в ячейке таблицы в колонтитуле. Таблица в колонтитуле документа ворд состоит из одной строки и двух столбцов. Вот в первом столбце я пытаюсь добавить в текст "Инструкция пользователя """ наименование из ячейки активного листа эксель (допустим A1). Подскажите, что нужно добавить в приведенный ниже код.

Код
Sub Кнопка1_Щелчок()    Dim objWrdApp As Object
    Dim objWrdDoc As Object
    
    On Error Resume Next
    Set objWrdApp = GetObject(, "Word.Application")
    If objWrdApp Is Nothing Then
        Set objWrdApp = CreateObject("Word.Application")
        Set objWrdDoc = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Шаблон_инструкция пользователя.docx")
        objWrdApp.Visible = True
    End If
    
    
    Set objWrdDoc = objWrdApp.Documents.Open(ThisWorkbook.Path & "\Шаблон_инструкция пользователя.docx")
        objWrdDoc.Bookmarks("БизнесРоль").Range.InsertAfter (Cells(1, 4).Value)
        objWrdDoc.Bookmarks("БизнесРоль1").Range.InsertAfter (Cells(1, 4).Value)
                
        objWrdDoc.ActiveWindow.ActivePane.View.SeekView = 9 'Открываем непервый верхний колонтитул
        With objWordApp.Selection
                    .Text = "Инструкция пользователя """
                    .Replacement.Text = "Инструкция пользователя Куратор договора"
                    .Forward = True
                    .Wrap = 1
                    .Format = False: .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    .Execute Replace:=2
        End With
        objWrdDoc.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument 'Закрываем колонтитул                  
           
        objWrdDoc.SaveAs (ThisWorkbook.Path & "\173_1.2.1.2.0-XX_" + Range("D1") + "_" + Format(Date, "dd/mm/yyyy") + ".docx")
        
        Application.CutCopyMode = False
        
    Set objWrdDoc = Nothing
    Set objWrdApp = Nothing
    
End Sub



С уважением,
Олег
 
Перейти    
Страницы: 1 2 3 4 След.
Наверх