Суббота, Май 30, 2020

Договоры из Excel в Word в разработке

Sub CreateOpenFindInWord()
    Const wdReplaceAll = 2
    Const wdFindContinue = 1
    Const wdOpenFormatAuto = 0
    Dim FindText(20) As String, RepText(20) As String, i As Integer, j As Integer
    Dim SelRange As Range, SelCol As Long, SelRow As Long, FirstSelCol As Long
    Dim HowRowCopy As Long, FirstSelRow As Long, k As Integer
    
    'Sheets(1).Select
    
'   Получаем координаты выделения
    SelRow = Selection.Rows.Count
    SelCol = Selection.Columns.Count
    FirstSelCol = Selection.Column
    FirstSelRow = Selection.Row
'Заполняем массив строк для поиска
    For i = 0 To Selection.Columns.Count + Selection.Column - 2
        FindText(i) = Range("A1").Offset(0, i).Text
        FindText(i) = "{" & FindText(i) & "}"
    Next i
'   Открывае Word
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = True
    
    For j = Selection.Row To Selection.Rows.Count + Selection.Row - 1
 'файл Word должен находиться в той же папке в которой находится Excel
        Set objDoc = objWord.Documents.Open(ThisWorkbook.Path & "\one.doc")
        Set objSelection = objWord.Selection
        k = 0
        For i = Selection.Column To Selection.Columns.Count + 1
            RepText(i - 1) = Range("A1").Offset((j - 1), (i - 1)).Text
            k = k + 1
        Next i
        For i = Selection.Column - 1 To Selection.Columns.Count
            objSelection.Find.ClearFormatting
            objSelection.Find.Replacement.ClearFormatting
            With objSelection.Find
                .Text = FindText(i)
                .Replacement.Text = ""
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
            End With
            If objSelection.Find.Execute Then
                objSelection.TypeText Text:=RepText(i)
                Do While objSelection.Find.Execute
                    objSelection.TypeText Text:=RepText(i)
                Loop
            End If
        Next i
        objWord.ActiveDocument.SaveAs Filename:=ThisWorkbook.Path & "\Зделан_" & RepText(Selection.Column - 1) & ".doc"
        objDoc.Close
    Next j
    objWord.Quit
    Set objWord = Nothing
End Sub


Sub CreateOpenFindInWord()

    Const wdReplaceAll = 2

    Const wdFindContinue = 1

    Const wdOpenFormatAuto = 0

    Dim FindText() As String, RepText() As String, i As Integer, j As Integer

    Dim SelRange As Range, SelCol As Long, SelRow As Long, FirstSelCol As Long

    Dim HowRowCopy As Long, FirstSelRow As Long, k As Integer

    

    Dim Filt As String, FilterIndex As Integer, Title As String, FileName As Variant

    If Selection.Rows.Count < 2 And Selection.Columns.Count < 2 Then

        MsgBox "âûäåëè äèàïàçîí"

        Exit Sub

    End If

    Filt = "Ñòàðûé Word(*.doc),*.doc," & "Íîâûé Word(*.docx),*.docx"

    FilterIndex = 5

    Title = "Âûáåðèòå èìïîðòèðóåìûé ôàéë"

    FileName = Application.GetOpenFilename _

    (FileFilter:=Filt, _

    FilterIndex:=FilterIndex, _

    Title:=Title)

    If FileName = False Then

        MsgBox "Ôàéë íå âûáðàí"

        Exit Sub

    End If

    

    'Sheets(1).Select

     

    SelRow = Selection.Rows.Count

    SelCol = Selection.Columns.Count

    FirstSelCol = Selection.Column

    FirstSelRow = Selection.Row

    ReDim FindText(Selection.Columns.Count)

    ReDim RepText(Selection.Rows.Count)

    For i = 0 To Selection.Columns.Count + Selection.Column - 2

        FindText(i) = Range("A1").Offset(0, i).Text

        FindText(i) = "{" & FindText(i) & "}"

    Next i

    Set objWord = CreateObject("Word.Application")

    objWord.Visible = True

    

    For j = Selection.Row To Selection.Rows.Count + Selection.Row - 1

        Set objDoc = objWord.Documents.Open(FileName)

        Set objSelection = objWord.Selection

        k = 0

        For i = Selection.Column To Selection.Columns.Count + 1

            RepText(i - 1) = Range("A1").Offset((j - 1), (i - 1)).Text

            k = k + 1

        Next i

        For i = Selection.Column - 1 To Selection.Columns.Count

            objSelection.Find.ClearFormatting

            objSelection.Find.Replacement.ClearFormatting

            With objSelection.Find

                .Text = FindText(i)

                .Replacement.Text = ""

                .Forward = True

                .Wrap = wdFindContinue

                .Format = False

                .MatchCase = False

                .MatchWholeWord = False

                .MatchWildcards = False

                .MatchSoundsLike = False

                .MatchAllWordForms = False

            End With

            If objSelection.Find.Execute Then

                objSelection.TypeText Text:=RepText(i)

                Do While objSelection.Find.Execute

                    objSelection.TypeText Text:=RepText(i)

                Loop

            End If

        Next i

        objWord.ActiveDocument.SaveAs FileName:=ThisWorkbook.Path & "\ãîòîâ_" & RepText(Selection.Column - 1) & ".doc"

        objDoc.Close

    Next j

    objWord.Quit

    Set objWord = Nothing

End Sub


Back to Top