Sub ExWordPruebam2()
Dim wordapp As Object
Dim fs As Object
Dim documento As Object
Dim objselection As Object
Dim fila, i As Integer
Dim wdApp As Object

Dim tema As String
Dim nomprof As String
Dim camino As String

Dim num, pts As Integer

Dim pregunta, opA, opB, opC, opD, ans, respC, explRC, dif, ref, obj, topic, pclave, prof As String

    Set wordapp = CreateObject("Word.Application")
    wordapp.Visible = True
    'Set fs = CreateObject("Scripting.FileSystemObject")

    Set documento = wordapp.Documents.Add
    Set objselection = documento.Range

    tema = ThisWorkbook.Worksheets(1).Cells(1, 2).Value
    objselection.Text = tema & vbCr

    nomprof = ThisWorkbook.Worksheets(1).Cells(6, 2).Value
    objselection.Collapse 0
    objselection.Text = nomprof & vbCr

    Range("A8").Select
    fila = Cells(Rows.Count, 1).End(xlUp).Row

    For i = 8 To fila

        num = ThisWorkbook.Worksheets(1).Cells(i, 1).Value
        pregunta = ThisWorkbook.Worksheets(1).Cells(i, 2).Value
        opA = ThisWorkbook.Worksheets(1).Cells(i, 3).Value
        opB = ThisWorkbook.Worksheets(1).Cells(i, 4).Value
        opC = ThisWorkbook.Worksheets(1).Cells(i, 5).Value
        opD = ThisWorkbook.Worksheets(1).Cells(i, 6).Value
        ans = ThisWorkbook.Worksheets(1).Cells(i, 7).Value
        respC = ThisWorkbook.Worksheets(1).Cells(i, 8).Value
        explRC = ThisWorkbook.Worksheets(1).Cells(i, 9).Value
        pts = ThisWorkbook.Worksheets(1).Cells(i, 10).Value
        dif = ThisWorkbook.Worksheets(1).Cells(i, 11).Value
        ref = ThisWorkbook.Worksheets(1).Cells(i, 12).Value
        obj = ThisWorkbook.Worksheets(1).Cells(i, 13).Value
        topic = ThisWorkbook.Worksheets(1).Cells(i, 14).Value
        pclave = ThisWorkbook.Worksheets(1).Cells(i, 15).Value
        prof = ThisWorkbook.Worksheets(1).Cells(i, 16).Value

        'objselection.Font.Bold = True
        With objselection
            .Collapse 0
            'A8...
            .Text = num & vbCr

            .Collapse 0
            .Text = pregunta & vbCr

            .Collapse 0
            .Text = "a. " & opA & vbCr

            .Collapse 0
            .Text = "b. " & opB & vbCr

            .Collapse 0
            .Text = "c. " & opC & vbCr

            .Collapse 0
            .Text = "d. " & opD & vbCr

            .Collapse 0
            .Text = "ANS: " & ans & vbCr

            .Collapse 0
            .Text = "Repuesta correcta " & vbCr & respC & vbCr

            .Collapse 0
            .Text = "Explicación de la respuesta " & vbCr & explRC & vbCr

            'J8....
            .Collapse 0
            .Text = "PTS: " & pts & vbCr

            .Collapse 0
            .Text = "DIF: " & dif & vbCr

            .Collapse 0
            .Text = "REF: " & ref & vbCr

            .Collapse 0
            .Text = "OBJ: " & obj & vbCr

            .Collapse 0
            .Text = "TOP: " & topic & vbCr

            .Collapse 0
            .Text = "KEY: " & pclave & vbCr

            .Collapse 0
            .Text = "NOT: " & prof & vbCr
        End With


        With wordapp.ActiveDocument
            camino = ThisWorkbook.Path & "\" & nomprof

            .SaveAs Filename:=camino & ".rtf"

            .Close savechanges:=True
        End With
    Next i

    wordapp.Application.Quit
    'Set fs = Nothing
    Set objselection = Nothing
    Set documento = Nothing
    Set wordapp = Nothing
End Sub