Try:
Sub Demo()
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim r As Long, i As Long, lRow As Long, lCol As Long
Dim StrFldr As String, StrTmplt As String, StrRcd As String
StrFldr = ActiveWorkbook.Path & "\"
StrTmplt = "Template.dotx"
With ActiveSheet.UsedRange
lRow = .SpecialCells(xlLastCell).Row
lCol = .SpecialCells(xlLastCell).Column
For r = 2 To lRow
If StrRcd <> .Range("A" & r).Value Then
StrRcd = .Range("A" & r).Value
For i = r To lRow
If .Range("A" & i).Value <> "" Then
If .Range("A" & i).Value <> StrRcd Then
i = i - 1
Exit For
End If
End If
Next
If i > lRow Then i = lRow
Set wdDoc = wdApp.Documents.Add(Template:=StrFldr & StrTmplt, AddToRecentFiles:=False, Visible:=False)
.Range("A" & r & ":" & .Cells(i, lCol).Address).Copy
With wdDoc
.Characters.Last.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
.SaveAs2 Filename:=StrFldr & StrRcd & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
.Close False
End With
r = i
End If
Next
End With
Application.CutCopyMode = False
wdApp.Quit
Application.ScreenUpdating = True
End Sub
Note: You'll need to supply the Word template's name. As coded, the macro assumes your document template is stored in the same folder as the workbook.