Выбор данных, выгружаемых из Excel в Word в зависимости от выбранного периода

Sub Защита_снятие()
'
' Защита_снятие Макрос
' Снятие защиты
 
 
 
 
 'ИНСТРУКЦИЯ:
 'Здесь 2 макроса, которые разделены горизонтальной полосой
 ' Порядок действий:
 '   - при необходимости меняете пароль в обоих макросах, по умолчанию 111
 '   - выделяете диапазон (столбцы) возможного редактирования во втором макросе, формулы остануться заблокированными (в скобках диапазон): Set oRange = myWorksheet.Range("W:AB")
 '   - если есть необходимость сделать листы, на которых всё можно редактировать, то во втором макросе описано, как это сделать
 
 
 
 
 
                  
         
         Dim iNumber As Long
    On Error Resume Next
    iNumber = Application.InputBox("Введите пароль", "Ввод")
    If iNumber = 0 Then
        MsgBox "Вы ничего не ввели! ", vbOKOnly, "Ошибка"
        End
     End If
     
    If iNumber = 111 Then
  'Сам пароль,  менять тут
 
 
 
 
 
    For Each myWorksheet In Worksheets
'Оператор цикла, значит, что действие для всех листов книги
    
    
    myWorksheet.Unprotect Password:="iNumber"
'Снятие защиты формата со всех листов
    
    myWorksheet.Select
 
    Selection.SpecialCells(xlCellTypeFormulas, 23).Select
'Выделяет на всех листах ячейки с формулами
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
        :=xlBetween
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
  
 
 
    Cells.Select
    ' выбор всех ячеек на всех листах
    
    Selection.Locked = True
    'указывает, что все ячейки будут потом защищены при блокировке
    
    Selection.FormulaHidden = False
    'указывает, что формулы НЕ будут невидимыми
 Next
   End
           
     Sheets("Данные").Select
    Range("D3").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=Список_диапазонов"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
          ' возвращает список периодов на место
           
           
    End If
      MsgBox "Пароль неправильный, защита не снята! ", vbOKOnly, "Запрет доступа от ............... службы"
'Исходящее сообщение при неправильно введённом пароле
   
End Sub
Sub Защита_установка()
'
' Защита_установка Макрос
' Установка защиты
 
 
        
        Dim myWorksheet As Worksheet
        Dim oRange As Range
        Dim oColumns As Range
        Dim oResult As Range
        Dim iNumber As Long
    On Error Resume Next
    iNumber = Application.InputBox("Введите пароль", "Ввод")
    If iNumber = 0 Then
        MsgBox "Вы ничего не ввели! ", vbOKOnly, "Ошибка"
        End
     End If
     
    If iNumber = 111 Then
    'Здесь устанавливается пароль
    
      
    
    For Each myWorksheet In Worksheets
  'Оператор цикла, значит, что действие для всех листов книги
    
If InStr(myWorksheet.Name, "UB") = 0 Then
       ' В кавычках указывается то значение, которое ищется в имени листа. Если стоит после скобки "=", то листы с этими буквами блокируются.
       ' Если вместо "=" поставить ">", то блокировка будет ТОЛЬКО на тех листах, в имени которых присутствуют эти символы
       
myWorksheet.Select False
 
 
                                                                                                   
           
     myWorksheet.Select
     Selection.SpecialCells(xlCellTypeFormulas, 23).Select
  'Выделяет на всех листах ячейки с формулами
        
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateCustom, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="ЛОЖЬ"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = "Ввод в эту ячейку запрещён"
        .InputMessage = ""
        .ErrorMessage = _
        "Нажмите клавишу Esc или щёлкните кнопку Отмена или закройте это окно" & Chr(10) & "" & Chr(10) & "Изменение формул заблокировано." & Chr(10) & ""
   'Текст сообщения об ошибке
        
        .ShowInput = True
        .ShowError = True
      
   
    
    End With
 
 myWorksheet.Select
     
     myWorksheet.EnableOutlining = True
     myWorksheet.EnableSelection = True
 
     
     myWorksheet.Protect Password:="iNumber", Contents:=True, Scenarios:=True, DrawingObjects:=False, UserinterfaceOnly:=True
                ' Блокирует все возможности, кроме группировки, копирования данных
 
  Selection.unselect
 
 
 
 
  Set oColumns = myWorksheet.Columns("I:J")
   
 myWorksheet.Select
    
  
    oColumns.Select
    Selection.Unprotect Password:="iNumber"
 
 Selection.Locked = False
 Selection.FormulaHidden = False
                ' Даёт возможность редактироваль на диапазоне, указанном выше
Selection.unselect
 
 
 
 End If
 
 
    Next
    End
    
 
    
        End If
      MsgBox "Пароль неправильный, защита не снята! ", vbOKOnly, "Запрет доступа от .................. службы"
        'Исходящее сообщение при неправильно введённом пароле
    
End Sub

Sub В_Ворд()
 
 
   Dim Ворд As New Word.Application, Документ As Word.Document
   Dim Лист As Excel.Worksheet, БДДС As Excel.Workbook
      
   Dim FName As Variant, ExName As Variant
   Dim Квартал As Long
 
       Ворд.Visible = True
 
FName = Application.GetOpenFilename(filefilter:="Word Files (*.docx), *.docx")
If FName <> False Then
Set Документ = Ворд.Documents.Open(FName)
         MsgBox "Открывается документ " & FName
Else
         MsgBox "Вы не выбрали документ ", vbOKOnly, "Ошибка"
        End
End If
    
 
'Работа с активной книгой Excel, с активным листом.
Set Лист = ActiveWorkbook.ActiveSheet
  
    
  Квартал = Лист.Range("E1").Value
    
 
    
 
    Лист.Range("Продажи" & Квартал).Copy
           ' Выбор диапазона копирования
           Документ.Bookmarks.Item("Продажи").Range.PasteExcelTable LinkedToExcel:=True, WordFormatting:=False, RTF:=False
           ' Выбор закладки для вставки
     
 
    Лист.Range("Прибыль" & Квартал).Copy
           ' Выбор диапазона копирования
           Документ.Bookmarks.Item("Прибыль").Range.PasteExcelTable LinkedToExcel:=True, WordFormatting:=False, RTF:=False
           ' Выбор закладки для вставки
        
        Application.CutCopyMode = False
        
        
  ExName = Application.GetOpenFilename(filefilter:="Excel Files (*.xls), *.xls")
If ExName <> False Then
Set БДДС = Workbooks.Open(ExName)
         MsgBox "Открывается книга " & FName
Else
         MsgBox "Вы не выбрали книгу ", vbOKOnly, "Ошибка"
        End
End If
        
        
 
     'Предположим, что данные в книге БДДС находятся на первом листе.
     БДДС.Worksheets(1).Range("Выручка" & Квартал).Copy
           ' Выбор диапазона копирования
           Документ.Bookmarks.Item("Выручка").Range.PasteExcelTable LinkedToExcel:=True, WordFormatting:=False, RTF:=False
           ' Выбор закладки для вставки
           
           Application.CutCopyMode = False
 
    
    
    
    
End Sub

With Ворд.FileDialog(msoFileDialogSaveAs)
    .AllowMultiSelect = False
    .ButtonName = "Сохранить"
    .Title = "Сохранение документа"
    .InitialFileName = "C:\Documents and Settings\Пользователь\Рабочий стол\"
    .Show
End With
    
Документ.Close Savechanges:=wdSaveChanges

Set Лист = ActiveWorkbook.Worksheets(1)

Sub Обновить_Связи()
 
  Dim oFld As Field 'Поле
  Dim OldFileName As String 'Старое имя файла
  Dim NewFileName As String 'Новое имя файла
  Dim FieldCode As String 'Код поля
  Dim ReplaceAllPath As Boolean 'Заменять весь путь к файлу или только имя
  Dim StartPath As Integer, EndPath As Integer 'Начало и конец пути к файлу в коде поля
  
  'Ввод старого имени файла
  OldFileName = InputBox("Укажите старое имя файла с расширением в ссылке, которое нужно изменить", "Изменение ссылок", OldFileName)
  If Len(OldFileName) = 0 Then Exit Sub
  
  'Выбор нового файла
  With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Выберите новый файл, с которым должен быть связан документ"
    .AllowMultiSelect = False
    .ButtonName = "Выбрать"
    .Filters.Clear
    .Filters.Add "Таблицы Excel", "*.xls; *.xlsx; *.xlsm"
    If .Show Then NewFileName = .SelectedItems(1) Else Exit Sub
  End With
  
  'Если изменилось не только имя, но и местоположение, то можно заменить весь путь
  ReplaceAllPath = MsgBox("Заменять весь путь? Нажмите ""Нет"", чтобы заменить только имя файла", vbYesNo + vbInformation, "Изменение ссылок") = vbYes
  
  NewFileName = Replace(NewFileName, "\", "\\")
  'Перебираем все поля в документе
  For Each oFld In ActiveDocument.Fields
    If oFld.Type = wdFieldLink Then 'Если поле является полем ссылки
      FieldCode = oFld.Code.Text
      If InStr(oFld.Code.Text, "Excel.Sheet") <> 0 And InStr(FieldCode, "\\" & OldFileName) <> 0 Then 'Если поле ссылается на лист Excel и на нужный файл
        If ReplaceAllPath Then 'Если нужно заменить весь путь
          StartPath = InStr(FieldCode, ":\\") - 2
          EndPath = InStr(FieldCode, "\\" & OldFileName) + Len(OldFileName) + 2
          FieldCode = Mid(FieldCode, 1, StartPath) & NewFileName & Mid(FieldCode, EndPath)
        Else 'Если нужно заменить только имя файла
          FieldCode = Replace(FieldCode, OldFileName, Mid(NewFileName, InStrRev(NewFileName, "\") + 1))
        End If
      End If
    End If
    oFld.Code.Text = FieldCode
  Next
End Sub

Sub Èçìåíèòü_èñòî÷íèê()
Dim dlgSelectFile As FileDialog 'FileDialog object
Dim thisField As Field
Dim selectedFile As Variant 'must be Variant to contain filepath of selected item
Dim newFile1 As Variant, newFile2 As Variant
Dim fieldCount As Integer
 
'create FileDialog object as File Picker dialog box
Set dlgSelectFile = Application.FileDialog(FileDialogType:=msoFileDialogFilePicker)
 
With dlgSelectFile
'use Show method to display File Picker dialog box and return user's action
If .Show = -1 Then
'step through each string in the FileDialogSelectedItems collection
For Each selectedFile In .SelectedItems
newFile1 = selectedFile 'gets new filepath
Next selectedFile
Else 'user clicked cancel
End If
End With
Set dlgSelectFile = Nothing
 
'create FileDialog object as File Picker dialog box
Set dlgSelectFile = Application.FileDialog(FileDialogType:=msoFileDialogFilePicker)
 
With dlgSelectFile
'use Show method to display File Picker dialog box and return user's action
If .Show = -1 Then
'step through each string in the FileDialogSelectedItems collection
For Each selectedFile In .SelectedItems
newFile2 = selectedFile 'gets new filepath
Next selectedFile
Else 'user clicked cancel
End If
End With
Set dlgSelectFile = Nothing
 
 
'update fields
 
fieldCount = ActiveDocument.Fields.Count
For x = 1 To fieldCount
If thisField.LinkFormat.SourceName = "*ÁÄÐ*.xlsm" Then
ActiveDocument.Fields(x).LinkFormat.SourceFullName = newFile1
ElseIf thisField.LinkFormat.SourceName = "*ÁÄÄÑ*.xlsm" Then
ActiveDocument.Fields(x).LinkFormat.SourceFullName = newFile2
End If
Next x
 
'Ниже кусок оригинального кода, при котором меняются все ссылки с прошлого на выбранный фаил
 
'fieldCount = ActiveDocument.Fields.Count
'For x = 1 To fieldCount
'ActiveDocument.Fields(x).LinkFormat.SourceFullName = newFile
'Next x
 
 
 
 
End Sub

fieldCount = ActiveDocument.Fields.Count
For x = 1 To fieldCount
If thisField.LinkFormat.SourceName = "*ÁÄÐ*.xlsm" Then
ActiveDocument.Fields(x).LinkFormat.SourceFullName = newFile1
ElseIf thisField.LinkFormat.SourceName = "*ÁÄÄÑ*.xlsm" Then
ActiveDocument.Fields(x).LinkFormat.SourceFullName = newFile2
End If
Next x