Attribute VB_Name = "towordfromexcel"
Option Explicit
Private Declare Function EmptyClipboard Lib "user32" () As Long
Public ToolbarAction
Public Sub init_Toolbar_word(s As String)
		On Error GoTo ErrorHandler
	Set ToolbarAction = CommandBars.Add(Name:="Перевод в MS Word", Position:=msoBarTop, Temporary:=True)
		ToolbarAction.Visible = True
	With ToolbarAction.Controls.Add(Type:=msoControlButton)
		 .FaceId = 313
		 .Style = msoButtonIcon
		 .Caption = "Скопировать таблицы в MS Word"
		 .OnAction = "towordfromexcel.PrepToExport"
	End With
	ShowHideLabels(1)
	ActiveWorkbook.ActiveSheet.Select
	With Selection
		.ReadingOrder = xlLTR
	End With
	Cells.Range("B1").Select
	MakeForm ' вызов формы выбора варианта экспорта

Exit Sub
ErrorHandler:
		Dim nErrorResult As Integer
		nErrorResult = 0
		nErrorResult = HandleErr(Err.Number)
		Err.Clear
		If nErrorResult = 0 Then
				Resume Next
		Else
				Exit Sub
		End If
End Sub

Public Sub PrepToExport()
   ' подключаем библиотеку WORD
	Dim iPath$, iFileName$, iCount%, iInd%
	iPath$ = Environ("WinDir")
	iInd% = 0
	iFileName$ = Application.path & "\MSWORD.OLB" 'Microsort Word 11.0 Object Library
	On Error GoTo ErrorHandler
	If Dir(iFileName$) <> "" Then
	   With ThisWorkbook.VBProject.References
			For iCount% = 1 To .Count
				If .Item(iCount%).FullPath = iFileName$ Then
				   iInd% = 1
				End If
			Next
			If iInd% = 0 Then
			.AddFromFile filename:=iFileName$
			End If
	   End With
	End If

	VBA.UserForms.Add(InvForm.Name).Show

Exit Sub
ErrorHandler:
		Dim nErrorResult As Integer
		nErrorResult = 0
		nErrorResult = HandleErr(Err.Number)
		Err.Clear
		If nErrorResult = 0 Then
				Resume Next
		Else
				Exit Sub
		End If
End Sub

Public Function excel2word(nVar)
	Dim rDoc As Word.Range, ws As Excel.Worksheet, oWord As Word.Application, cRngSel As String
	Dim nmDiaps As Name, nmCurDiap As String, cVarName As String, rVarName As Range, Target, cTarget as String
	Dim rRngNew As Excel.Range, cRngNew As String, RngS As Excel.Range, RngF As Excel.Range
	Dim cMsg As String, Style, nResponse As Integer, cTitle As String, cDefault As String, cCellText As String
	Dim bUprng As Word.Bookmark, nPos As Integer, rUprng As Word.Range, rMBr As Word.Range
	Dim rOBr As Word.Range, rCBr As Word.Range, rBBr As Word.Range, rEBr As Word.Range
	Dim cAdr As String, rRes As Excel.Range, rUprngOrig As Word.Range, nActionRes as Integer

	On Error GoTo ErrorHandler
	cCellText = ""
	Set oWord = CreateObject("Word.Application")
	cVarName = Cells.Range("A2").value
	oWord.Documents.Open filename:=cVarName, Revert:=True
	cCellText = Cells.Range("A3").Text
	Set ws = ActiveWorkbook.ActiveSheet
	cTarget = ""
	If nVar = 3 Then
		cMsg = "Введите номер области"    ' номер selection
		cTitle = "Выбор цели"    ' заголовок
		cDefault = "0"    ' по умолчанию область без номера
		Target = InputBox(cMsg, cTitle, cDefault)
		If Target = "" Then
			If IsEmpty(oWord) = False Then oWord.Documents(dir(cVarName)).Close
			Exit Function
		End If
		If LTrim(Str(Target)) = "0" Then cTarget = "" Else cTarget = LTrim(Str(Target))
	End If
	If nVar = 4 Then
		With oWord.ActiveDocument
			For Each bUprng In .Bookmarks
				Set rUprng = bUprng.Range
				Set rUprngOrig = rUprng.Duplicate
				cCellText = InadmisReplace(cCellText)
				' Если строка стала короче - есть смысл искать координаты
				cVarName = bUprng.Name
				nResponse = Len(cVarName)
				cVarName = Replace(cVarName, cCellText, "")
				if nResponse > Len(cVarName) Then
					rUprng.Text = StrReverse(bUprng.Name)
					With rUprng
						Set rOBr = rUprng.Duplicate
						rOBr.Find.Execute Findtext:="*^095*^095*", MatchWildcards:=True
						If rOBr.Find.Found Then
							cAdr = StrReverse(Left(rOBr.Text, Len(rOBr.Text) - 1))
							cAdr = Replace(cAdr, Chr(95), Chr(58))
							Set rRes = Range(cAdr)
							rRes.Copy
							rUprng.Text = rUprngOrig.Text
							bUprng.Select
							oWord.Selection.MoveRight Unit:=wdCharacter, Count:=1
							nActionRes = oWord.Selection.Expand(wdTable)
							If nActionRes > 0 Then oWord.Selection.Cells.Delete Else oWord.Selection.MoveLeft (wdCharacter)
							oWord.Selection.PasteExcelTable False, True, False
						Else
							rUprng.Text = rUprngOrig.Text
						End If
					End With
				 End If
			Next bUprng
			If IsEmpty(oWord) = False Then oWord.Application.Visible = True
		End With
		Exit Function
	End If
	cVarName = Cells.Range("A3").Text
	cVarName = InadmisReplace(cVarName)
	With Cells
		Set RngS = .Find(What:="headd", LookIn:=xlFormulas, MatchCase:=True)
		Set RngF = .Find(What:="finishh", LookIn:=xlFormulas, MatchCase:=True)
		If Not RngS Is Nothing And Not RngF Is Nothing Then
			Set rRngNew = Range(Cells(RngS.Row + 1, RngF.column), Cells(RngF.Row - 1, RngS.column))
			nResponse = 0
			Set rVarName = Selection
			ws.Cells(RngS.Row + 1, RngS.column + nResponse).Activate
			While Not Len(ActiveCell.FormulaR1C1) = 0
				Set rRngNew = Nothing
				Set rRngNew = ws.Range(Cells(RngS.Row + 1, RngF.column), Cells(RngF.Row - 1, RngS.column + nResponse))
				nResponse = nResponse + 1
				ws.Cells(RngS.Row + 1, RngS.column + nResponse).Activate
			Wend
			cRngNew = rRngNew.Address(False, False)
		End If
	End With
	cRngSel = rVarName.Address(False, False)
	cRngSel = Replace(cRngSel, Chr(58), Chr(95))
	cRngNew = cGetRange(cVarName, oWord, cRngNew, cRngSel, nVar, cTarget)
	If UCase(cRngNew) = "1" Then
		Set rRngNew = rVarName
		cRngNew = "selection" + cTarget + Chr(95) + cRngSel
	Else
		If cRngNew = "0" Then
			cRngNew = ""
		Else
			Set rRngNew = Cells.Range(cRngNew)
		End If
	End If
	' добавление к имени варианта адреса ячейки
	cRngNew = Chr(95) + cRngNew
	cRngNew = Replace(cRngNew, Chr(58), Chr(95))
	cVarName = UCase(cVarName + cRngNew)
	cVarName = Replace(cVarName, "SELECTION", "")
	ActiveWorkbook.Names.Add Name:=cVarName, RefersToR1C1:=rRngNew
	For Each nmDiaps In ActiveWorkbook.Names
		nmCurDiap = UCase(nmDiaps.Name)
		nmDiaps.RefersToRange.Copy
		Set rDoc = oWord.ActiveDocument.Range
		' обработка несуществующей закладки
		If rDoc.Bookmarks.Exists(nmCurDiap) = True Then
			rDoc.Bookmarks.Item(nmCurDiap).Select
			nActionRes = oWord.Selection.Expand(wdTable)
			If nActionRes > 0 Then oWord.Selection.Cells.Delete
			oWord.Selection.PasteExcelTable False, True, False
		End If
	Next nmDiaps
	rRngNew.Select
	If cCellText <> "" Then Cells.Range("A3").value = cCellText
	If IsEmpty(oWord) = False Then oWord.Application.Visible = True
Exit Function
ErrorHandler:
		Dim nErrorResult As Integer
		nErrorResult = 0
		nErrorResult = HandleErr(Err.Number)
		Err.Clear
		If nErrorResult = 0 Then
			Resume Next
		Else
			If cCellText <> "" Then Cells.Range("A3").value = cCellText
			If IsEmpty(oWord) = False Then oWord.Application.Visible = True
			Exit Function
		End If
End Function

Private Function cGetRange(cVarName, oWord, cRngNew, cRngSel, nVar, cTarget)
	'поиск меток
	' "{" - 123, "|" - 124,"}" - 125
	Dim rOBr As Word.Range, rCBr As Word.Range, rBBr As Word.Range
	Dim pPrh As Word.Paragraph, rPrh As Word.Range, rTBr As Word.Range
	Dim bStrChk As Boolean, rEBr As Word.Range, rMBr As Word.Range
	On Error GoTo ErrorHandler
	cGetRange = "0" ' 1 - selection, 0 - табличную часть, адрес - координаты
	For Each pPrh In oWord.ActiveDocument.Paragraphs
		Set rPrh = pPrh.Range
		With oWord.ActiveDocument
			Set rOBr = rPrh.Duplicate
			Set rCBr = rPrh.Duplicate
			Set rMBr = rPrh.Duplicate
			Set rTBr = rPrh.Duplicate
			Set rEBr = rPrh.Duplicate
			Set rBBr = rPrh.Duplicate
			rOBr.Find.Execute (Chr(123))
			If rOBr.Find.Found Then
				rCBr.Find.Execute (Chr(125))
				If rCBr.Find.Found Then
					Set rBBr = .Range(rOBr.End, rCBr.Start)
					Set rEBr = rBBr.Duplicate
					Set rTBr = rBBr.Duplicate
					rEBr.Find.Execute (Chr(13))
					If rEBr.Find.Found Then
						Set rBBr = Nothing
					End If
					If nVar = 2 Then Set rBBr = Nothing ' должно печатать табличную часть
					If Not rBBr Is Nothing Then
						' получаем адрес тут
						Set rOBr = rPrh.Duplicate
						Set rCBr = rPrh.Duplicate
						rOBr.Find.Execute (Chr(124))
						If rOBr.Find.Found Then
							Set rTBr = .Range(rTBr.Start, rOBr.Start)
							rCBr.Find.Execute (Chr(125))
							If rCBr.Find.Found Then
								Set rBBr = .Range(rOBr.End, rCBr.Start)
								Set rEBr = rBBr.Duplicate
								rEBr.Find.Execute (Asc(13))
								If rEBr.Find.Found Then
									Set rBBr = Nothing
								End If
								bStrChk = False ' контролирует корректность адреса
								If Not rBBr Is Nothing Then
										rTBr.Text = InadmisReplace(rTBr.Text)
									If rTBr.Text = cVarName Then
										bStrChk = rBBr.Text Like "*:*"
										If bStrChk = True Then
											cGetRange = UCase(rBBr.Text)
										Else
											If UCase(rBBr.Text) = "SELECTION" + cTarget Then
												cGetRange = "1"
												rBBr.Text = rBBr.Text + Chr(95) + cRngSel
											End If
										End If
										Set rMBr = rBBr.Duplicate
										Set rOBr = rPrh.Duplicate
										rOBr.Find.Execute (Chr(123))
										Set rBBr = .Range(rOBr.End, rCBr.Start)
									End If
								End If
							End If
						End If
						Set rPrh = Nothing
						If UCase(rTBr.Text) = UCase(cVarName) Then
							Set rPrh = rBBr.Duplicate
							rBBr.Collapse Direction:=wdCollapseStart
							With rPrh.Find
								.Text = Chr(58)
								.Replacement.Text = Chr(95)
								.Execute Replace:=wdReplaceAll
								.Text = Chr(124)
								.Replacement.Text = Chr(95)
								.Execute Replace:=wdReplaceAll
							End With
							With .Bookmarks
								If cGetRange = "0" Then
									cGetRange = cRngNew ' далее передаем адрес
									cRngNew = rPrh.Text + cTarget + cRngNew
									cRngNew = InadmisReplace(cRngNew)
									cRngNew = Replace(cRngNew, "_SELECTION", "")
									.Add Range:=rBBr, Name:=cRngNew
									.DefaultSorting = wdSortByName
									.ShowHidden = False
								ElseIf cGetRange = "1" Then
									cRngNew = rPrh.Text + cTarget + Chr(95) + cRngSel
									cRngNew = InadmisReplace(cRngNew)
									cRngNew = Replace(cRngNew, "_SELECTION", "")
									.Add Range:=rBBr, Name:=cRngNew
									.DefaultSorting = wdSortByName
									.ShowHidden = False
								Else
									cRngNew = cVarName + cTarget + Chr(95) + cGetRange
									cRngNew = InadmisReplace(cRngNew)
									cRngNew = Replace(cRngNew, "_SELECTION", "")
									.Add Range:=rBBr, Name:=cRngNew
									.DefaultSorting = wdSortByName
									.ShowHidden = False
								End If
								If Not rPrh Is Nothing Then
									rOBr.Delete
									rCBr.Delete
									rPrh.Text = ""
								End If
							End With
						End If
					End If
				End If
			End If
		End With
	Next pPrh
Exit Function
ErrorHandler:
		Dim nErrorResult As Integer
		nErrorResult = 0
		nErrorResult = HandleErr(Err.Number)
		Err.Clear
		If nErrorResult = 0 Then
				Resume Next
		Else
				Exit Function
		End If
End Function

Public Function ToWord(lPortrait)
' переводит таблицы сформированного отчета в ворд приложение
		Dim oWord As Object, RngC As Excel.Range, RngS As Excel.Range, RngE As Excel.Range, RngF As Excel.Range, ws As Worksheet
		Dim FirstAdrС As String, FirstAdrS As String, FirstAdrE As String, FirstAdrF As String, oPage As Object, cPath As String
		Dim oRsC As Object, oRsS As Object, oRsE As Object, oRsF As Object
		Dim sRsCFName As String, sRsSFName As String, sRsEFName As String, sRsFFName As String
		Dim sRsCFBold As Boolean, sRsSFBold As Boolean, sRsEFBold As Boolean, sRsFFBold As Boolean
		Dim sRsCFSize As Long, sRsSFSize As Long, sRsEFSize As Long, sRsFFSize As Long
		Dim sRsCFItal As Boolean, sRsSFItal As Boolean, sRsEFItal As Boolean, sRsFFItal As Boolean
		Dim sRsCLeft As Single, sRsSLeft As Single, sRsELeft As Single, sRsFLeft As Single
		Dim sRsCRight As Single, sRsSRight As Single, sRsERight As Single, sRsFRight As Single
		Dim sRsCFirst As Single, sRsSFirst As Single, sRsEFirst As Single, sRsFFirst As Single
		Dim sRsCLign As Long, sRsSLign As Long, sRsELign As Long, sRsFLign As Long, cEdIzm As String
		Dim sRsCStyle As Variant, sRsSStyle As Variant, sRsEStyle As Variant, sRsFStyle As Variant
		Dim Ph1 As Word.Paragraph, Ph2 As Word.Paragraph, Ph3 As Word.Paragraph, Ph4 As Word.Paragraph
		Dim rStart As Word.Range, rFinish As Word.Range, rBody As Word.Range, TempPath As String
		Dim lPage As Long, i As Long, lCurPage As Long, rPage As Word.Range, sPathReport As String
		Dim rParS As Word.Range, rParE As Word.Range, rParF As Word.Range, lUseTemp As Long, lFormHead As Long
		On Error GoTo ErrorHandler
		' позволяем пользователю выбрать - использовать шаблон или нет (влечет за собой некоторые изменения в стилях документа)
		Dim cMsg As String, Style, cTitle As String, nResponse As Integer
		cMsg = "Использовать шаблон для создания отчета?"
		Style = vbYesNo + vbExclamation + vbDefaultButton1
		cTitle = "Внимание!"
		nResponse = MsgBox(cMsg, Style, cTitle)
		If nResponse = vbYes Then
		   lUseTemp = 1
		Else
		   lUseTemp = 0
		End If
		cMsg = "Формировать шапку на каждой странице? (возможны искажения)"
		Style = vbYesNo + vbExclamation + vbDefaultButton1
		cTitle = "Внимание!"
		nResponse = MsgBox(cMsg, Style, cTitle)
		If nResponse = vbYes Then
		   lFormHead = 1
		Else
		   lFormHead = 0
		End If
		ShowHideLabels(0)
		Set oWord = CreateObject("Word.Application")
		With oWord
			.Visible = False
			' путь к шаблону
			cEdIzm = Excel.ActiveSheet.Range("A4").value
			sPathReport = Excel.ActiveSheet.Range("A2").value
			If Dir(sPathReport) = "towordexc.dot" Then
				.Documents.Add TEMPLATE:=sPathReport, NewTemplate:=False, DocumentType:=0, Visible:=False
				.Documents(1).Activate
				With .ActiveDocument
						Set Ph1 = .Paragraphs.Item(1)
						Set Ph2 = .Paragraphs.Item(2)
						Set Ph3 = .Paragraphs.Item(3)
						Set Ph4 = .Paragraphs.Item(4)
					Set oRsC = .Range(Start:=Ph1.Range.Start, End:=Ph1.Range.End)
					Set oRsS = .Range(Start:=Ph2.Range.Start, End:=Ph2.Range.End)
					Set oRsE = .Range(Start:=Ph3.Range.Start, End:=Ph3.Range.End)
					Set oRsF = .Range(Start:=Ph4.Range.Start, End:=Ph4.Range.End)
					If Not IsNull(oRsC) Then
						Set sRsCStyle = oRsC.Style
						With oRsC.Font
								sRsCFName = oRsC.Font.Name
								sRsCFBold = oRsC.Font.Bold
								sRsCFSize = oRsC.Font.size
								sRsCFItal = oRsC.Font.Italic
						End With
						sRsCLeft = Ph1.LeftIndent
						sRsCRight = Ph1.RightIndent
						sRsCFirst = Ph1.FirstLineIndent
						sRsCLign = Ph1.Alignment
					Else
						sRsCStyle = wdStyleBodyText
						sRsCFName = "Times New Roman"
						sRsCFBold = False
						sRsCFSize = 14
						sRsCFItal = True
					End If
					If Not IsNull(oRsS) Then
						Set sRsSStyle = oRsS.Style
						With oRsS.Font
								sRsSFName = oRsS.Font.Name
								sRsSFBold = oRsS.Font.Bold
								sRsSFSize = oRsS.Font.size
								sRsSFItal = oRsS.Font.Italic
						End With
						sRsSLeft = Ph2.LeftIndent
						sRsSRight = Ph2.RightIndent
						sRsSFirst = Ph2.FirstLineIndent
						sRsSLign = Ph2.Alignment
					Else
						sRsSStyle = wdStyleBodyText
						sRsSFName = "Times New Roman"
						sRsSFBold = True
						sRsSFSize = 14
						sRsSFItal = False
					End If
					If Not IsNull(oRsE) Then
						Set sRsEStyle = oRsE.Style
						With oRsE.Font
								sRsEFName = oRsE.Font.Name
								sRsEFBold = oRsE.Font.Bold
								sRsEFSize = oRsE.Font.size
								sRsEFItal = oRsE.Font.Italic
						End With
						sRsELeft = Ph3.LeftIndent
						sRsERight = Ph3.RightIndent
						sRsEFirst = Ph3.FirstLineIndent
						sRsELign = Ph3.Alignment
					Else
						sRsEStyle = wdStyleBodyText
						sRsEFName = "Times New Roman"
						sRsEFBold = False
						sRsEFSize = 14
						sRsEFItal = False
					End If
					If Not IsNull(oRsF) Then
						Set sRsFStyle = oRsF.Style
						With oRsF.Font
								sRsFFName = oRsF.Font.Name
								sRsFFBold = oRsF.Font.Bold
								sRsFFSize = oRsF.Font.size
								sRsFFItal = oRsF.Font.Italic
						End With
						sRsFLeft = Ph4.LeftIndent
						sRsFRight = Ph4.RightIndent
						sRsFFirst = Ph4.FirstLineIndent
						sRsFLign = Ph4.Alignment
					Else
						sRsFStyle = wdStyleBodyText
						sRsFFName = "Times New Roman"
						sRsFFBold = False
						sRsFFSize = 14
						sRsFFItal = False
					End If
			   End With
			Else
				.Documents.Add NewTemplate:=False, DocumentType:=0, Visible:=False
				.Documents(1).Activate
				sRsCStyle = wdStyleBodyText
				sRsCFName = "Times New Roman"
				sRsCFBold = False
				sRsCFSize = 14
				sRsCFItal = True
				sRsCLign = 2
				sRsSStyle = wdStyleBodyText
				sRsSFName = "Times New Roman"
				sRsSFBold = True
				sRsSFSize = 14
				sRsSFItal = False
				sRsSLign = 1
				sRsEStyle = wdStyleBodyText
				sRsEFName = "Times New Roman"
				sRsEFBold = False
				sRsEFSize = 14
				sRsEFItal = False
				sRsELign = 1
				sRsFStyle = wdStyleBodyText
				sRsFFName = "Times New Roman"
				sRsFFBold = False
				sRsFFSize = 14
				sRsFFItal = False
				sRsFLign = 1
			End If
		End With
		oWord.Documents(1).Select
			' определяем области отчета
						For Each ws In ActiveWorkbook.Worksheets
								ws.Select
					With ws.Cells
						Set RngS = .Find(What:="startt", _
										LookIn:=xlValues, _
										MatchCase:=True)
						If Not RngS Is Nothing Then
							FirstAdrS = RngS.Address
							Set RngE = .Find(What:="endd", _
											LookIn:=xlValues, _
											MatchCase:=True)
							If Not RngE Is Nothing Then
								FirstAdrE = RngE.Address
								Set RngF = .Find(What:="finishh", _
												LookIn:=xlValues, _
												MatchCase:=True)
									If Not RngF Is Nothing Then
										FirstAdrF = RngF.Address
										' диапазон и адрес начала листа для уголка
										Set RngC = Range(Cells(1, 1), Cells(1, RngS.column))
										FirstAdrС = RngC.Address
										' форматирование без шаблона из Excel
										If lUseTemp = 0 Then
											With RngC.Font
												sRsCStyle = wdStyleBodyText
												sRsCFName = IfNull(.Name, "Times New Roman")
												sRsCFBold = IfNull(.Bold, False)
												sRsCFSize = IfNull(.size, 14)
												sRsCFItal = IfNull(.Italic, False)
											End With
											With RngS.Font
												sRsSStyle = wdStyleBodyText
												sRsSFName = IfNull(.Name, "Times New Roman")
												sRsSFBold = IfNull(.Bold, False)
												sRsSFSize = IfNull(.size, 14)
												sRsSFItal = IfNull(.Italic, False)
											End With
											With RngE.Font
												sRsEStyle = wdStyleBodyText
												sRsEFName = IfNull(.Name, "Times New Roman")
												sRsEFBold = IfNull(.Bold, False)
												sRsEFSize = IfNull(.size, 14)
												sRsEFItal = IfNull(.Italic, False)
											End With
											With RngF.Font
												sRsFStyle = wdStyleBodyText
												sRsFFName = IfNull(.Name, "Times New Roman")
												sRsFFBold = IfNull(.Bold, False)
												sRsFFSize = IfNull(.size, 14)
												sRsFFItal = IfNull(.Italic, False)
											End With
										End If
										'EmptyClipboard
										' области известны, осуществляем экспорт в Word
										' используем настройку из диалога
										If lPortrait = 1 Then oWord.WordBasic.TogglePortrait
										' уголок
										.Range(FirstAdrС, FirstAdrS).Copy
										oWord.Selection.PasteSpecial DataType:=wdPasteText
										' шапка
										.Range(FirstAdrS, FirstAdrE).Copy
										oWord.Selection.PasteSpecial DataType:=wdPasteText
										Set rStart = oWord.ActiveDocument.Range
										With rStart.Find
											.Text = "starttstartt"
											.MatchCase = True
											.MatchWholeWord = True
											.Wrap = wdFindContinue
											.Replacement.Text = "startt"
											.Execute Replace:=wdReplaceAll
										End With
										' тело
										If RngE.MergeCells = True Then
											FirstAdrE = RngE.Offset(1, 1).Address
										Else
											FirstAdrE = RngE.Offset(1, 0).Address
										End If
										FirstAdrF = RngF.Offset(-1, 0).Address
									.Range(FirstAdrE, FirstAdrF).Copy
									If lUseTemp = 1 Then
											oWord.Selection.PasteExcelTable False, True, False
									Else
											oWord.Selection.PasteExcelTable False, False, False
									End If
										' подпись
										FirstAdrF = RngF.Address
											.Range(FirstAdrF, ws.Cells.SpecialCells(xlCellTypeLastCell)).Copy
											oWord.Selection.PasteSpecial DataType:=wdPasteText
											'EmptyClipboard
										' вставка произведена, добавляем форматирование по шаблону
										With oWord.ActiveDocument
											' форматируем таблицу
											If RngE.MergeCells = True Then ' не использовать RngE для левых областей
												.Select
												With oWord.Selection
													For i = 1 To .Tables.Count
															.Tables(i).Select
															' удаляем пустую колонку
															.EndKey Unit:=wdRow
															.Columns.Delete
													Next i
												End With
											End If
											.Select
											With oWord.Selection
												For i = 1 To .Tables.Count
														.Tables(i).Select
														.Rows.AllowBreakAcrossPages = False
														.Tables(i).AutoFitBehavior (wdAutoFitWindow)
												Next i
											End With
											Set rStart = .Range
											Set rFinish = .Range
											Set rBody = .Range
											rStart.Find.Execute ("startt")
											rFinish.Find.Execute ("endd")
											Set rBody = .Range(rStart.End, rFinish.Start)
											With rBody
												.AutoFormat
												.Style = sRsSStyle
												With .Font
													.Name = sRsSFName
													.Bold = sRsSFBold
													.size = sRsSFSize
													.Italic = sRsSFItal
												End With
												With .Paragraphs
														.LeftIndent = IfNull(sRsSLeft, 0)
														.RightIndent = IfNull(sRsSRight, 0)
														.FirstLineIndent = IfNull(sRsSFirst, 0)
														.Alignment = IfNull(sRsSLign, 1)
												End With
											End With
											Set rStart = .Range
											Set rFinish = .Range
											Set rBody = .Range
											rStart.Find.Execute ("endd")
											rFinish.Find.Execute ("finishh")
											Set rBody = .Range(rStart.End + 1, rFinish.Start)
											With rBody
												.AutoFormat
												.Style = sRsEStyle
												With .Font
													.Name = sRsEFName
													.Bold = sRsEFBold
													.size = sRsEFSize
													.Italic = sRsEFItal
												End With
												With .Paragraphs
														.LeftIndent = IfNull(sRsELeft, 0)
														.RightIndent = IfNull(sRsERight, 0)
														.FirstLineIndent = IfNull(sRsEFirst, 0)
														.Alignment = IfNull(sRsELign, 1)
												End With
											End With
											Set rStart = .Range
											Set rFinish = .Range
											Set rBody = .Range
											rStart.Find.Execute ("finishh")
											Set rBody = .Range(rStart.End, rFinish.End)
											With rBody
												.AutoFormat
												.Style = sRsFStyle
												With .Font
													.Name = sRsFFName
													.Bold = sRsFFBold
													.size = sRsFFSize
													.Italic = sRsFFItal
												End With
												With .Paragraphs
														.LeftIndent = IfNull(sRsFLeft, 0)
														.RightIndent = IfNull(sRsFRight, 0)
														.FirstLineIndent = IfNull(sRsFFirst, 0)
														.Alignment = IfNull(sRsFLign, 1)
												End With
											End With
											Set rStart = .Range
											Set rFinish = .Range
											Set rBody = .Range
											rFinish.Find.Execute ("startt")
											Set rBody = .Range(rStart.Start, rFinish.Start)
											With rBody
												.AutoFormat
												.Style = sRsFStyle
												With .Font
													.Name = sRsCFName
													.Bold = sRsCFBold
													.size = sRsCFSize
													.Italic = sRsCFItal
												End With
												With .Paragraphs
														.LeftIndent = IfNull(sRsCLeft, 0)
														.RightIndent = IfNull(sRsCRight, 0)
														.FirstLineIndent = IfNull(sRsCFirst, 0)
														.Alignment = IfNull(sRsCLign, 2)
												End With
											End With
											' формируем шапку на каждой странице
											' ищем шапку
											Set rStart = .Range
											Set rFinish = .Range
											Set rBody = .Range
											rStart.Find.Execute ("startt")
											rFinish.Find.Execute ("headd")
											Set rBody = .Range(rStart.Start, rFinish.End)
											Set rStart = .Range
											Set rFinish = .Range
											With rBody
												For i = 1 To rBody.Paragraphs.Count
												.Paragraphs(i).Format.Alignment = sRsSLign
												Next i
												' удаляем строку с "head"
												rFinish.Find.Execute ("headd")
												rFinish.StartOf wdRow, wdMove
												rFinish.EndOf wdRow, wdExtend
												'исправлено ошибочное добавление новой строки
												rFinish.Cells.Delete ShiftCells:=wdDeleteCellsEntireRow
												'удаляем строку с "end" и выравниваем вправо cEdIzm
												rStart.Find.Execute (cEdIzm)
												rStart.ParagraphFormat.Alignment = wdAlignParagraphRight
												rStart.Move wdParagraph, 1
												rStart.EndOf wdParagraph, wdExtend
												rStart.Delete
												.Copy
											End With
											' шапку нашли, вставляем ее на каждую страницу
											If lFormHead = 1 Then
												.Select
												With oWord.Selection
													.StartOf Unit:=wdStory, Extend:=wdMove
													For lCurPage = 1 To .Information(wdNumberOfPagesInDocument) * 2
														If lCurPage <> 1 Then
															.InsertBreak Type:=wdPageBreak
															.PasteAndFormat (wdFormatOriginalFormatting)
															.EndKey Unit:=wdLine, Extend:=wdExtend
															.Delete
														End If
														If lCurPage = .Information(wdNumberOfPagesInDocument) Then
															Exit For
														End If
														.GoToNext (1)
													Next lCurPage
												End With
											End If
											Set rStart = .Range
											Set rFinish = .Range
											Set rBody = .Range
											rStart.Find.Execute ("finishh")
											If rStart.End > rFinish.End Then
												Set rBody = .Range(rStart.End, rFinish.End)
												With rBody
													For i = 1 To rBody.Paragraphs.Count
													.Paragraphs(i).Format.Alignment = sRsELign
													Next i
												End With
											End If
											' применяем к уголку правое выравнивание
											Set rStart = .Range
											rStart.Find.Execute ("startt")
											Set rBody = .Range(0, rStart.Start)
											With rBody.Find
												.Text = Chr(9)
												'.MatchCase = True
												'.MatchWholeWord = False
												.Wrap = wdFindContinue
												.Replacement.Text = ""
												.Execute Replace:=wdReplaceAll
											End With
											rBody.ParagraphFormat.Alignment = sRsCLign
											' удаляем метки (start,finish, end)
											With oWord.ActiveDocument
												Set rStart = .Range
												Set rFinish = .Range
												Set rBody = .Range
												With rStart.Find
													.Text = "startt"
													.MatchCase = True
													.MatchWholeWord = False
													.Wrap = wdFindContinue
													.Replacement.Text = Chr(32)
													.Execute Replace:=wdReplaceAll
												End With
												With rFinish.Find
													.Text = "finishh"
													.MatchCase = True
													.MatchWholeWord = False
													.Wrap = wdFindContinue
													.Replacement.Text = Chr(32)
													.Execute Replace:=wdReplaceAll
												End With
												With rBody.Find
													.Text = "endd"
													.MatchCase = True
													.MatchWholeWord = False
													.Wrap = wdFindContinue
													.Replacement.Text = Chr(32)
													.Execute Replace:=wdReplaceAll
												End With
												oWord.Selection.HomeKey Unit:=wdStory
											End With
											' форматирование сформированного отчета в Word'e
											' показываем результат
											If IsEmpty(oWord) = False Then oWord.Application.Visible = True
										End With
									End If
							End If
						End If
					End With
				Next ws
				ShowHideLabels(1)
Exit Function
ErrorHandler:
		Dim nErrorResult As Integer
		nErrorResult = 0
		nErrorResult = HandleErr(Err.Number)
		Err.Clear
		If nErrorResult = 0 Then
				Resume Next
		Else
				If IsEmpty(oWord) = False Then oWord.Application.Visible = True
				Exit Function
		End If
End Function

Public Function PrecWord()
' ищем метку в точности соответствующую формату {название варианта|selectionX}
' если найдена - преобразовываем ее к общему виду: "имя_адрес" и создаем соответствующий диапазон
	Dim cMsg As String, Style, nResponse As Integer, cTitle As String, cDefault As String
	Dim rDoc As Word.Range, ws As Excel.Worksheet, oWord As Word.Application, cRngSel As String
	Dim cVarName As String, rRngSel As Excel.Range, cRngAddr As String, cRngSelMod As String
	Dim rWord As Word.Range, cTarget As String, rRngNew As Excel.Range, cCellText As String
	On Error GoTo ErrorHandler
	cCellText = Cells.Range("A3")
	cMsg = "Введите номер области"    ' номер selection
	cTitle = "Выбор цели"    ' заголовок
	cDefault = "0"    ' по умолчанию область без номера
	cTarget = ""
	cTarget = LTrim(str(InputBox(cMsg, cTitle, cDefault)))
	If cTarget = "0" Then cTarget = ""
	cRngSel = UCase(Cells.Range("A2").Text + Chr(124) + "selection" + cTarget)
	cRngSelMod = InadmisReplace(cRngSel)
	cRngSel = UCase(Chr(123) + cRngSel + Chr(125))
	Set rRngNew = Excel.Selection
	cRngAddr = rRngNew.Address(False, False)
	cRngAddr = InadmisReplace(cRngAddr)

	Set oWord = CreateObject("Word.Application")
	cVarName = Cells.Range("A1").value
	oWord.Documents.Open filename:=cVarName, Revert:=True
	Set rWord = oWord.ActiveDocument.Range
	rWord.Find.Execute (cRngSel)
	If rWord.Find.Found Then
		rWord.Text = ""
				With oWord.ActiveDocument.Bookmarks
				cRngSelMod = Replace(cRngSelMod, Chr(124), Chr(95))
				cRngSelMod = cRngSelMod + Chr(95) + cRngAddr
				cRngSelMod = Replace(cRngSelMod, "_SELECTION","")
				.Add Range:=rWord, Name:=UCase(cRngSelMod)
				.DefaultSorting = wdSortByName
				.ShowHidden = False
				End With
				ActiveWorkbook.Names.Add Name:=UCase(cRngSelMod), RefersToR1C1:=rRngNew
				rRngNew.Copy
				rWord.PasteExcelTable False, True, False
		End If
	If cCellText <> "" Then Cells.Range("A3").value = cCellText
	If IsEmpty(oWord) = False Then oWord.Application.Visible = True

Exit Function
ErrorHandler:
	Dim nErrorResult As Integer
	nErrorResult = 0
	nErrorResult = HandleErr(Err.Number)
	Err.Clear
	If nErrorResult = 0 Then
			Resume Next
	Else
			If cCellText <> "" Then Cells.Range("A2").value = cCellText
			If IsEmpty(oWord) = False Then oWord.Application.Visible = True
			Exit Function
	End If
End Function

Private Function IfNull(value As Variant, Optional NullValue As Variant = "") As Variant
	If IsNull(value) Then
		IfNull = NullValue
	Else
		IfNull = value
	End If
End Function

Private Function ShowFileInfo(filespec)
	Dim fs, f
	Set fs = CreateObject("Scripting.FileSystemObject")
	Set f = fs.GetFile(filespec)
	ShowFileInfo = f.path
End Function

Private Function InadmisReplace(cOrigString)
' заменяем недопустимые знаки в строке
				InadmisReplace = Replace(cOrigString, Chr(32), Chr(95))
				InadmisReplace = Replace(InadmisReplace, Chr(33), Chr(95))
				InadmisReplace = Replace(InadmisReplace, Chr(34), Chr(95))
				InadmisReplace = Replace(InadmisReplace, Chr(35), Chr(95))
				InadmisReplace = Replace(InadmisReplace, Chr(36), Chr(95))
				InadmisReplace = Replace(InadmisReplace, Chr(37), Chr(95))
				InadmisReplace = Replace(InadmisReplace, Chr(38), Chr(95))
				InadmisReplace = Replace(InadmisReplace, Chr(39), Chr(95))
				InadmisReplace = Replace(InadmisReplace, Chr(40), Chr(95))
				InadmisReplace = Replace(InadmisReplace, Chr(41), Chr(95))
				InadmisReplace = Replace(InadmisReplace, Chr(42), Chr(95))
				InadmisReplace = Replace(InadmisReplace, Chr(43), Chr(95))
				InadmisReplace = Replace(InadmisReplace, Chr(44), Chr(95))
				InadmisReplace = Replace(InadmisReplace, Chr(45), Chr(95))
				InadmisReplace = Replace(InadmisReplace, Chr(46), Chr(95))
				InadmisReplace = Replace(InadmisReplace, Chr(47), Chr(95))
				InadmisReplace = Replace(InadmisReplace, Chr(58), Chr(95))
				InadmisReplace = Replace(InadmisReplace, Chr(59), Chr(95))
				InadmisReplace = UCase(Replace(InadmisReplace, Chr(92), Chr(95)))
Exit Function
ErrorHandler:
		Dim nErrorResult As Integer
		nErrorResult = 0
		nErrorResult = HandleErr(Err.Number)
		Err.Clear
		If nErrorResult = 0 Then
				Resume Next
		Else
				Exit Function
		End If
End Function

Private Function MakeForm()
	Dim InvForm As Object 'VBComponent
	Dim OKBut As Object
	Dim OptBut1 As Object
	Dim OptBut2 As Object
	Dim OptBut3 As Object
	Dim OptBut4 As Object
	Dim ChBox As Object
	Dim nLine As Integer, nInc As Integer
	On Error GoTo ErrorHandler
	'Application.VBE.MainWindow.Visible = False
	' Создание диалогового окна UserForm
	Set InvForm = ThisWorkbook.VBProject. _
	VBComponents.Add(3) 'vbext_ct_MSForm
	With InvForm
			.Properties("Name") = "InvForm"
			.Properties("Caption") = "Печать:"
			.Properties("Width") = 110
			.Properties("Height") = 160
	End With
	' Добавление элементов управления
	Set OKBut = InvForm.Designer.Controls _
	.Add("forms.CommandButton.1")
	With OKBut
			.Caption = "OK"
			.Height = 24
			.Width = 60
			.Left = 18
			.Top = 105
	End With
	Set OptBut1 = InvForm.Designer.Controls _
	.Add("forms.OptionButton.1")
	With OptBut1
			.Caption = "    Документа"
			.Height = 18
			.Width = 90
			.Left = 6
			.Top = 6
	End With
	Set OptBut2 = InvForm.Designer.Controls _
	.Add("forms.OptionButton.1")
	With OptBut2
			.Caption = "    Точно по метке"
			.Height = 18
			.Width = 90
			.Left = 6
			.Top = 24
	End With
	Set OptBut3 = InvForm.Designer.Controls _
	.Add("forms.OptionButton.1")
	With OptBut3
			.Caption = "    Выбранной части"
			.Height = 18
			.Width = 90
			.Left = 6
			.Top = 42
	End With
	Set OptBut4 = InvForm.Designer.Controls _
	.Add("forms.OptionButton.1")
	With OptBut4
			.Caption = "    Повторная"
			.Height = 18
			.Width = 90
			.Left = 6
			.Top = 60
	End With
	Set ChBox = InvForm.Designer.Controls _
	.Add("forms.CheckBox.1")
	With ChBox
			.Caption = "альбомный формат"
			.Height = 18
			.Width = 90
			.Left = 6
			.Top = 80
			.Enabled = False
			.value = False
	End With

	With InvForm.CodeModule
		nLine = .CountOfLines
		nInc = 1
		.InsertLines nLine + nInc, "Sub CommandButtonl_Click()"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "Private Sub CommandButton1_Click()"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "Dim nSel As Integer"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "nSel = 0"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "InvForm.Enabled = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "'InvForm.Hide"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "'InvForm.Visible = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "Unload Me"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "If OptionButton1.value = True and CheckBox1.value = True Then"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "    towordfromexcel.ToWord (1)"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "ElseIf OptionButton1.value = True Then"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "    towordfromexcel.ToWord (0)"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "ElseIf OptionButton2.value = True Then"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "    towordfromexcel.PrecWord"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "ElseIf OptionButton3.value = True Then"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "   towordfromexcel.excel2word (3)"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "ElseIf OptionButton4.value = True Then"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "    towordfromexcel.excel2word (4)"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "End If"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "'InvForm.Hide"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "'Unload InvForm"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "End Sub"
		nInc = nInc + 1
	
		.InsertLines nLine + nInc, "Private Sub OptionButton1_Click()"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "OptionButton1.value = True"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "CheckBox1.Enabled = True"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "OptionButton2.value = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "OptionButton3.value = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "OptionButton4.value = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "End Sub"
		nInc = nInc + 1
		
		.InsertLines nLine + nInc, "Private Sub OptionButton2_Click()"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "OptionButton1.value = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "CheckBox1.Enabled = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "CheckBox1.Value = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "OptionButton2.value = True"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "OptionButton3.value = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "OptionButton4.value = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "End Sub"
		nInc = nInc + 1
		
		.InsertLines nLine + nInc, "Private Sub OptionButton3_Click()"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "OptionButton1.value = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "CheckBox1.Enabled = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "CheckBox1.Value = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "OptionButton2.value = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "OptionButton3.value = True"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "OptionButton4.value = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "End Sub"
		nInc = nInc + 1
		
		.InsertLines nLine + nInc, "Private Sub OptionButton4_Click()"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "OptionButton1.value = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "CheckBox1.Enabled = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "CheckBox1.Value = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "OptionButton2.value = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "OptionButton3.value = False"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "OptionButton4.value = True"
		nInc = nInc + 1
		.InsertLines nLine + nInc, "End Sub"
		nInc = nInc + 1
	End With
Exit Function
ErrorHandler:
		Dim nErrorResult As Integer
		nErrorResult = 0
		nErrorResult = HandleErr(Err.Number)
		Err.Clear
		If nErrorResult = 0 Then
				Resume Next
		Else
				Exit Function
		End If
End Function

Private Function HandleErr(nError)
		Dim cMsg As String, Style, nResponse As Integer, cTitle As String, cDefault As String
		HandleErr = 0
		Select Case nError
		Case 5941
				Exit Function
	Case 462
		cMsg = "Целевой документ открыт, продолжение невозможно"
		HandleErr = 1
	Case 5174
		cMsg = "Целевой документ не найден, проверьте путь к шаблону"
		HandleErr = 1
	Case 4198
		cMsg = "Целевой документ открыт, операция отменена"
		HandleErr = 1
	Case Else
			cMsg = "Обнаружена ошибка " + str(nError) + Chr(13) + ". Описание:" + IfNull(Err.Description, " ") + Chr(13) + ". Источник:" + IfNull(Err.Source, " ")
	End Select
	Style = vbOKOnly + vbExclamation + vbDefaultButton1
	cTitle = "Внимание!"
	nResponse = MsgBox(cMsg, Style, cTitle)
End Function

Private Function ShowHideLabels(bShow)
	Dim RngJ As Excel.Range, RngG As Excel.Range, wsJ As Worksheet
	For Each wsJ In ActiveWorkbook.Worksheets
		wsJ.Select
		With wsJ.Cells
				Set RngJ = .Find(What:="endd", _
				LookIn:=xlFormulas, _
				MatchCase:=False)
				If Not RngJ Is Nothing Then
					RngJ.EntireRow.Hidden = bShow
				End If
				Set RngJ = .Find(What:="headd", _
				LookIn:=xlFormulas, _
				MatchCase:=False)
				If Not RngJ Is Nothing Then
					RngJ.EntireRow.Hidden = bShow
				End If
				Set RngJ = .Find(What:="startt", _
				LookIn:=xlFormulas, _
				MatchCase:=False)
				If Not RngJ Is Nothing Then
					RngJ.EntireRow.Hidden = bShow
				End If
				Set RngJ = .Find(What:="finishh", _
				LookIn:=xlFormulas, _
				MatchCase:=False)
				If Not RngJ Is Nothing Then
					RngJ.EntireRow.Hidden = bShow
				End If
		End With
	Next wsJ

End Function