Como exportar de excel a word, pero en un párrafo o página determinada.

Hola tengo el código este, pero este código es para un documento q sólo es una página. ¿Podría cambiar este código? Para que se vuelque la información a un párrafo o a una página concreta.

Private Sub CheckBox1_Click()
End Sub
Private Sub CommandButton1_Click()
Dim miche As OLEObject
Dim mfila As Long
Dim mcolu As Long
Dim miword As Object 'New Word.Application
Dim midoc As Object 'Word.Document
Dim nn As Long
Dim jj As Long
Set miword = CreateObject("word.application")
Set midoc = miword.Application.Documents.Add(Template:=ActiveWorkbook.Path & "\plantilla1.dot")
miword.Visible = True
For Each miche In Me.OLEObjects
If Left(miche.Name, 8) = "CheckBox" And miche.BottomRightCell.Cells.Column = 1 And miche.Object.Value = -1 Then
nn = nn + 1
End If
Next
If nn = 0 Then
MsgBox ("No Seleccionados")
midoc.Close savechanges:=False
miword.Quit
Set miword = Nothing
Exit Sub
End If
midoc.Tables(1).Select
midoc.Application.Selection.Copy
For jj = 1 To nn - 1
midoc.Application.Selection.EndKey unit:=6 'wdStory
midoc.Application.Selection.InsertBreak Type:=7 'wdPageBreak
midoc.Application.Selection.TypeParagraph
midoc.Application.Selection.PasteAndFormat (0) 'wdPasteDefault)
midoc.Application.Selection.TypeParagraph
Next
midoc.Application.Selection.HomeKey unit:=6 'wdStory
nn = 0
For Each miche In ActiveSheet.OLEObjects
If Left(miche.Name, 8) = "CheckBox" And miche.BottomRightCell.Cells.Column = 1 And miche.Object.Value = -1 Then
nn = nn + 1
mfila = miche.BottomRightCell.Cells.Row
mcolu = miche.BottomRightCell.Cells.Column
ActiveSheet.Cells(mfila, "B").Activate
ActiveCell.CopyPicture
midoc.Tables(nn).Cell(2, 1).Range.Select
midoc.Application.Selection.Paste
' ActiveSheet.Cells(mfila, "C").Activate
' ActiveCell.CopyPicture
' midoc.Tables(nn).Cell(1, 1).Range.Select
' midoc.Application.Selection.Paste
midoc.Tables(nn).Cell(2, 2).Range.Text = ActiveSheet.Cells(mfila, "D").Text
midoc.Tables(nn).Cell(4, 2).Range.Text = ActiveSheet.Cells(mfila, "G").Text
midoc.Tables(nn).Cell(6, 2).Range.Text = ActiveSheet.Cells(mfila, "H").Text
midoc.Tables(nn).Cell(1, 1).Range.Text = "NOMBRE: " & Replace(Replace(ActiveSheet.Cells(mfila, "C").Text, Chr(13), ""), Chr(10), "")
End If
Next
midoc.Application.Selection.HomeKey unit:=6 'wdStory
Application.WindowState = xlMinimized
Workbooks("libropasarword1.xls").Close savechanges:=False
midoc.Application.WindowState = 1 'wdWindowStateMaximize
midoc.SaveAs ActiveWorkbook.Path & "\ficherofecha_" & Format(Now, "yyyymmddhhnnss") & ".doc"
'MsgBox (Selection.OLEObjects.Count)
'MsgBox (Me.OLEObjects(1).Name)
End Sub

Gracias, un saludo

Añade tu respuesta

Haz clic para o