엑셀연동 워드문서 일괄생성 (메일머지 기능)

관련:

지식인1, 지식인2, 지식인3

 

아래내용은 위 링크 1번에서 질문자님의 질문에 대한 지식인 '큰형'님의 소스를 기반으로 수정한 내용입니다.

 

데이터는 아래와 같은 엑셀문서 양식에 들어 있습니다.

2행에 있는 여러가지 "{항목}" 문자열을 찾아서

워드문서 생성이 O 라면

각 행의 데이터로 바꿔서 아래 워드 문서를 만들어서

지정된 파일명으로 저장하는 일괄처리 작업입니다.

 

작업을 위해서는 기준이 될 워드문서 내에 {항목}과 같은 표시가 만들어져 있어야 합니다.

{항목}은 1개가 아니라 여러군데 있어도 됩니다.

예전 아래한글 프로그램에 있던 메일머지 기능과 유사합니다.

엑셀 데이터를 기반으로 여러장의 워드 문서를 만들 때 유용하겠습니다.

 

코드는 아래를 참고하세요.

Option Explicit
Sub 직사각형1_Click()
    'Dim w As Word.Application, D As Word.Document
    Dim w As Object, D As Object
    Dim n As Integer, m As Integer
    Dim T As Variant
    Dim docFile As String
    Dim lastRow As Long
    Dim SPR As String
    Dim myRange As Object   'Word.Range
    
    SPR = Application.PathSeparator     '// 윈도우의 경우 '\'문자
    docFile = ThisWorkbook.Path & SPR & "표준계약서"
    
    'Application.ScreenUpdating = False
    lastRow = Cells(Rows.Count, 3).End(xlUp).Row
    If lastRow < 3 Then Exit Sub
    
    T = Range("B2:O" & lastRow).Value  '//*********** B열부터 O열까지
     
    ' 워드에서 표준계약서.docx문서 복사본 오픈
    Set w = CreateObject("Word.Application")
    w.Visible = True
        
    For n = 2 To UBound(T)
        
        If T(n, UBound(T, 2)) = "O" Then    '저장여부가 "O"이면
            Set D = w.Documents.Open(Filename:=docFile & ".docx", ReadOnly:=True, Visible:=True)
        
            Set myRange = D.Content
            
            For m = 1 To (UBound(T, 2) - 2) '// ************* B:O열까지에서 N열,O열 2개열은 제외
                With myRange.Find
                    .ClearFormatting
                    .Replacement.ClearFormatting
                    .Text = T(1, m): .Replacement.Text = T(n, m)
                    .Execute Replace:=2     '// 2: wdReplaceAll
                    'Debug.Print T(1, m); T(n, m)
                End With
            Next m
                
            '문서 저장 및 종료
            'D.SaveAs2 Filename:=docFile & "_" & T(n, 2) & ".docx"  ' // ***** 표준계약서_홍길동.docx
            D.SaveAs2 Filename:=ThisWorkbook.Path & SPR & T(n, UBound(T, 2) - 1) & ".docx"
            D.Close True '저장
        End If
        
    Next n

    
    Set D = Nothing: w.Quit False: Set w = Nothing '초기화
End Sub

 

입력값2.xlsm

0.02MB

표준계약서.docx

0.02MB