Option Explicit
Dim wdApp As Object, wdDoc As Object
Dim fio As String, login As String
Dim listname As String, dpz As String, fname As String, fldname As String
Dim r As Range, c As Range
Dim i As Long

Sub PutList()

'определение исходных данных
fname = TextBox1.Text
listname = TextBox2.Text
fldname = TextBox3.Text
dpz = TextBox4.Text
If inlist("", listname, dpz, fname, fldname) Then
    MsgBox "Заполните поля ввода", vbInformation, "Сообщение"
    Exit Sub
End If
Set ws = ThisWorkbook.Worksheets(listname)
Set r = ws.Range(dpz)

'Word: или уже запущен, или запустить
On Error Resume Next
Err.Clear
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
    Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
With wdApp
  .Visible = False
  Set wdDoc = .Documents.Add(fname)
End With

'Действия
For i = 1 To r.Rows.Count
    fio = Trim(r.Cells(i, 1).Value)
    login = Trim(r.Cells(i, 2).Value)
    Set wdDoc = wdApp.Documents.Add(fname)
    With wdDoc
        .Bookmarks("fio").Range.Text = fio
        .Bookmarks("fio").Range.Words(1).Font.Bold = True ' здесь проблема
        .Bookmarks("fio").Range.Words(1).Font.Underline = 1 ' и здесь проблема
        .Bookmarks("login").Range.Text = login
        .Bookmarks("login").Range.Words(1).Font.Bold = True ' и здесь проблема
        .SaveAs Filename:=fldname & "\" & fio & ".docx"
        .Close SaveChanges:=False
    End With
Next i

'Конец
wdApp.Quit
MsgBox "Готово", vbInformation, "Сообщение"
End Sub

'Word: или уже запущен, или запустить
On Error Resume Next
Err.Clear
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = False
End If

'Действия
Dim x
For i = 1 To r.Rows.Count
    fio = Trim(r.Cells(i, 1).Value)
    login = Trim(r.Cells(i, 2).Value)
    Set wdDoc = wdApp.Documents.Add(fname)
    With wdDoc
        Set x = .Bookmarks("fio").Range
        x.Text = fio
        x.Font.Bold = True
        x.Font.Underline = 1
        Set x = .Bookmarks("login").Range
        x.Text = login
        x.Font.Bold = True
        .SaveAs Filename:=fldname & "\" & fio & ".docx"
        .Close SaveChanges:=False
    End With
Next i 

Option Explicit
Dim wdApp As Object, wdDoc As Object
Dim listname As String, dpz As String, dpz_bm As String, dpz_val As String
Dim fname As String, fldname As String, bm As String
Dim r As Range, r1 As Range, c As Range
Dim i As Long, j As Integer
Dim x, bmrk

Private Sub ВсеЗакладки(ByVal fname As String)
'вывод в комбобокс имен всех закладок в ворд-документе
If Dir(fname, vbNormal) = "" Then
    MsgBox "Файл не найден", vbInformation, "Сообщение"
    Exit Sub
End If
ComboBox1.Clear
On Error Resume Next
Err.Clear
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = False
End If
On Error GoTo 0
Set wdDoc = wdApp.Documents.Add(fname)
    With wdDoc
        For Each bmrk In .BookMarks
            ComboBox1.AddItem bmrk.Name
        Next
        .Close SaveChanges:=False
    End With
wdApp.Quit
End Sub

Sub PutToWrdDoc()
Dim fam As String
'определение исходных данных
fname = TextBox1.Text
listname = TextBox2.Text
fldname = TextBox3.Text
dpz_bm = TextBox5.Text
dpz_val = TextBox4.Text
If inlist("", listname, dpz_bm, dpz_val, fname, fldname) Then
    MsgBox "Заполните поля ввода", vbInformation, "Сообщение"
    Exit Sub
End If
If Dir(fldname, vbDirectory) = "" Then
    Err.Clear
    On Error Resume Next
    MkDir fldname
        If Err.Number <> 0 Then
            MsgBox "Невозможно создать папку", vbInformation, "Сообщение"
            On Error GoTo 0
            Exit Sub
        End If
End If
Set ws = ThisWorkbook.Worksheets(listname)
Set r1 = ws.Range(dpz_bm) 'закладки (заголовок таблицы)
Set r = ws.Range(dpz_val) 'значения (тело таблицы)
'Word: или уже запущен, или запустить
On Error Resume Next
Err.Clear
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = False
End If
On Error GoTo 0
'действия
For i = 1 To r.Rows.Count
    Set wdDoc = wdApp.Documents.Add(fname)
    With wdDoc
    fam = Trim(r.Cells(i, 1).Value) 'фамилия идет в имя файла.docx
        For j = 1 To r1.Columns.Count
            bm = Trim(r1.Cells(1, j).Value) 'имя закладки в шаблоне, оно же в заголовочной строке таблицы
                Set x = .BookMarks(bm).Range
                x.Text = r.Cells(i, j).Value
                If inlist(bm, "fio") Then
                    x.Font.Bold = True
                    x.Font.Underline = 1
                Else
                    x.Font.Bold = True
                End If
        Next j
        .SaveAs Filename:=fldname & "\" & fam & ".docx"
        .Close SaveChanges:=False
    End With
Next i
'конец
wdApp.Quit
MsgBox "Готово", vbInformation, "Сообщение"
End Sub

Private Sub CommandButton1_Click()
PutToWrdDoc
End Sub

Private Sub CommandButton2_Click()
Unload Me
End Sub

Private Sub CommandButton3_Click()
TextBox2.Text = ActiveSheet.Name
End Sub

Private Sub CommandButton4_Click()
TextBox4.Text = Application.Selection.Address(False, False)
Set ws = Application.ActiveSheet
ws.Cells(1, 1).Select
End Sub

Private Sub CommandButton5_Click()
Dim fn As Variant
fn = Application.GetOpenFilename(, , "Зайдите в Вашу конечную папку, выберите любой файл и нажмите Открыть")
If fn <> False Then TextBox1.Text = fn
End Sub

Private Sub CommandButton6_Click()
Dim fn As Variant
fn = Application.GetOpenFilename(, , "Зайдите в Вашу конечную папку, выберите любой файл и нажмите Открыть")
If fn <> False Then
    fn = Mid(fn, 1, InStrRev(fn, "\") - 1)
    TextBox3.Text = fn
End If
End Sub

Private Sub CommandButton7_Click()
TextBox5.Text = Application.Selection.Address(False, False)
Set ws = Application.ActiveSheet
ws.Cells(1, 1).Select
End Sub

Private Sub CommandButton8_Click()
Dim ffname As String
ffname = Trim(TextBox1.Text)
If ffname = "" Then Exit Sub
ВсеЗакладки ffname
End Sub

Public Function inlist(s As Variant, ParamArray spisok() As Variant) As Boolean
inlist = False
For Each elem In spisok
    If elem = s Then
        inlist = True
        Exit For
    End If
Next
End Function