原理

獲取單元格變數，然後複製檔案A到B的同時重新命名

Sub bath_writing_sc()

Dim i As Integer
Dim ID, ENname, CNname, Month, Day, FullPath As String

Set docApp = CreateObject("Word.Application")

For i = 2 To Worksheets(1).UsedRange.Rows.Count
ID = Worksheets(1).Cells(i, 2).Value
ENname = Worksheets(1).Cells(i, 3).Value
CNname = Worksheets(1).Cells(i, 4).Value
Month = Worksheets(1).Cells(i, 5).Value
Day = Worksheets(1).Cells(i, 6).Value
FullPath = Worksheets(1).Cells(i, 8).Value


FileCopy ThisWorkbook.Path & "\Model.docx", ThisWorkbook.Path & "\ok\" & FullPath & ".docx"


Set wd = docApp.documents.Open(ThisWorkbook.Path & "\ok\" & FullPath & ".docx")
    docApp.Visible = False
    'docApp.Activate     '讓開啟後的檔案顯示在桌面（成為當前活動文件）
 
        Set myRange = wd.Content
         myRange.Find.Execute findtext:="#Name#", replacewith:=ENname, Replace:=2
         myRange.Find.Execute findtext:="#ID#", replacewith:=ID, Replace:=2
         myRange.Find.Execute findtext:="#Day#", replacewith:=Day, Replace:=2
         myRange.Find.Execute findtext:="#Month#", replacewith:=Month, Replace:=2
wd.Save
     
Next

docApp.Quit
MsgBox "Mission Completed"
End Sub