Option Explicit
Sub Word_Individuales()
Dim mArchivo As Variant, fdocument As Document
Dim miExcel As String, target As Variant, obSQL As String
Dim cnn As Object, dataread As Object, filas As Long
Dim i As Long, iname As Variant, midoc As Document
Dim miArchivo As String, campo As String, miCarpeta As Variant

Dim paginasDocumento As Integer
Dim totalPaginas As Integer
Dim pagActual As Integer
Dim nombreDocs As String

Dim lngStart As Long
Dim lngEnd As Long
Dim lngDocNum As Long
Dim docOld As Document
Dim docNew As Document

Set fdocument = ThisDocument

Set mArchivo = Application.FileDialog(msoFileDialogOpen)
    
If mArchivo.Show = 0 Then Exit Sub
    miExcel = mArchivo.SelectedItems(1)

Set miCarpeta = Application.FileDialog(msoFileDialogFolderPicker)

If miCarpeta.Show = 0 Then Exit Sub
    miCarpeta = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

Set target = Documents.Add

obSQL = "SELECT [BBDD$].[INFORME] FROM [BBDD$]"

Set cnn = New ADODB.Connection
With cnn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .Connectionstring = "DATA SOURCE=" & miExcel
    .Properties("Extended Properties") = "Excel 8.0"
    .Open
End With

Set dataread = New ADODB.Recordset
With dataread
    .Source = obSQL
    .ActiveConnection = cnn
    .CursorLocation = adUseClient
    .CursorType = adOpenForwardOnly
    .LockType = adLockReadOnly
    .Open
End With

dataread.MoveFirst

filas = dataread.RecordCount
Selection.InsertAfter dataread.Fields(0)

Do Until dataread.EOF
    dataread.MoveNext

If dataread.EOF = "Verdadero" Then Exit Do
    campo = Replace(dataread.Fields(0), "-", " ")
    Selection.InsertAfter Chr(11) & campo
Loop

Selection.ConvertToTable Separator:=wdSeparateByDefaultListSeparator, _
numcolumns:=1, Numrows:=filas, AutoFitBehavior:=wdAutoFitFixed

Set midoc = ActiveDocument

pagActual = 1

    Do
        Set iname = midoc.Tables(1).Cell(i, 1).Range

        miArchivo = Mid(Replace(miCarpeta & iname.Text, Chr(13), ""), 1, _
        Len(Replace(miCarpeta & iname.Text, Chr(13), "")) - 1)
    
    lngStart = 1
    Set docOld = fdocument
       ' ActiveWindow.Selection.HomeKey Unit:=wdStory
    With Selection.Find
     'With docOld
        
        '.ClearFormatting
        .Text = "Hacer de conocimiento*^13"
        .MatchWildcards = True
        .Wrap = wdFindStop
        If i = midoc.Tables(1).Rows.Count Then Exit Sub
        
            Selection.Collapse Direction:=wdCollapseEnd
            lngEnd = Selection.End
            ' Copy the "section"
            docOld.Range(lngStart, lngEnd).Copy
            'Create a new document to paste text from clipboard.
            Set docNew = Documents.Add
            Selection.Paste
            ' Save the new document
            lngDocNum = lngDocNum + 1
            docNew.SaveAs FileName:="Section_" & lngDocNum & ".docx", _
                FileFormat:=wdFormatXMLDocument
            docNew.Close
            ' set new start
            lngStart = lngEnd + 1
    End With
   
pagActual = pagActual + paginasDocumento
    i = i + 1
    Loop Until i = midoc.Tables(1).Rows.Count

ActiveDocument.Close SaveChanges:=False
End Sub