** NORMAS DEL FORO **
Inicio del foro Inicio del foro > Otros de Microsoft: Windows y Office > Excel
  Mensajes nuevos Mensajes nuevos RSS - Registros de  Excel a Word...
  Preguntas frecuentes Preguntas frecuentes  Buscar en el foro   Eventos   Registro Registro  Iniciar sesion Iniciar sesion

Tema cerradoRegistros de Excel a Word...

 Responder Responder
Autor
Mensaje
John_Arnedo Ver desplegable
Habitual
Habitual
Avatar

Unido: 13/Febrero/2009
Localización: Colombia
Estado: Sin conexión
Puntos: 196
Enlace directo a este mensaje Tema: Registros de Excel a Word...
    Enviado: 13/Mayo/2019 a las 07:50
Pues eso, he encontrado cualquier cantidad de ejemplos para pasar información de excel a word pero ninguno hace lo que quiero y a mi particularmente nada se me ocurre. 

Deseo que el código permita que la información que contenga cada campo de la fila seleccionada de una tabla de excel pase a un documento de word previamente formateado para ello. 

Mil gracias
Arriba
Marciana Ver desplegable
Asiduo
Asiduo
Avatar

Unido: 20/Septiembre/2004
Localización: Argentina
Estado: Sin conexión
Puntos: 323
Enlace directo a este mensaje Enviado: 12/Junio/2019 a las 20:01
Tengo este ejemplo. Un poco extenso pero funciona. Está en versión 2003. Ojalá te sirva. Debe haber previamente creado un documento word. Preguntame, puedo ayudarte. 

    Dim Word As New Word.Application

    Dim Nota As Word.Document

   

    Dim Tabla As Word.Table

    Dim NombreArchivo As String

    Dim myRange As Object

    Dim Fila As Integer

 

Public Function NotaSimple(IdOCO As Long) As Boolean

 

    NotaSimple = False

    Directorio = DLookup("Path", "Parametros", "IdPath = 1")

   

    FOCO = Nz(DLookup("OCO", "OCOs", "IdOCO = " & IdOCO), "0")

    If FOCO = "0" Then

        MsgBox "No existe la OCO"

        Exit Function

     End If

     FExpediente = Nz(DLookup("NroExpediente", "OCOs", "IdOCO = " & IdOCO), "N/D")

     FFechaExpediente = Nz(DLookup("FechaExpediente", "OCOs", "IdOCO = " & IdOCO), "N/D")

    Word.Visible = True

 

    Set Nota = Word.Documents.Open(FileName:=Directorio & "Notas\NotaModelo.doc", ReadOnly:=True)

 

    NroOCO = DLookup("OCO", "OCOs", "IdOCO = " & IdOCO)

   

    FEmpresa = DLookup("Empresa", "OCOs", "IdOCO = " & IdOCO)

    NroNota = InputBox("Ingresar Nro de nota")

    If FEmpresa = "Farma KD" Then

        NombreArchivo = Directorio & "Notas\Nota " & NroNota & " OC " & NroOCO & "-" & Nz(DLookup("Barra", "OCOs", "IdOCO = " & IdOCO), "0") & ".doc"

    Else

        NombreArchivo = Directorio & "LAFKEN\Notas\Nota " & NroNota & " OC " & NroOCO & "-" & Nz(DLookup("Barra", "OCOs", "IdOCO = " & IdOCO), "0") & ".doc"

    End If

    NroOCO = NroOCO & "/" & Nz(DLookup("Barra", "OCOs", "IdOCO = " & IdOCO), "0")

    Nota.SaveAs NombreArchivo

   

 

    Set myRange = Word.ActiveDocument.Content

    Fila = 0

    Set Tabla = Nota.Tables(1)

 

'*****************************************************************************

'fecha

'*****************************************************************************

    

     'With myRange.Find

     With Nota.Content.Find

    .ClearFormatting

    .Replacement.ClearFormatting

    .Text = "#Fecha#"

    .Replacement.Text = Date

    .Execute Replace:=wdReplaceAll

    End With

'*****************************************************************************

'OCO

'*****************************************************************************

     'With myRange.Find

    With Nota.Content.Find

 

    .ClearFormatting

    .Replacement.ClearFormatting

    .Text = "#OC1#"

    .Replacement.Text = NroOCO

    .Execute Replace:=wdReplaceAll

    End With

'*****************************************************************************

'OCO

'*****************************************************************************

     'With myRange.Find

    With Nota.Content.Find

    .ClearFormatting

    .Replacement.ClearFormatting

    .Text = "#OC2#"

    .Replacement.Text = NroOCO

    .Execute Replace:=wdReplaceAll

   End With

 

'*****************************************************************************

'NroNota

'*****************************************************************************

'     With myRange.Find

   

    With Nota.Content.Find

    .ClearFormatting

    .Replacement.ClearFormatting

    .Text = "#nronota#"

    .Replacement.Text = NroNota

    .Execute Replace:=wdReplaceAll

    End With

 

'*****************************************************************************

'Tabla de datos

'*****************************************************************************

 

    rs.Open "Select * from Paso5Nota where IdOCO = " & IdOCO & " Order By idestado, idfactura", CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly

    If rs.EOF And rs.BOF Then

        MsgBox "No hay renglones para OCO: " & FOCO

        GoTo Salida

    End If

   

    '**************************************************

    'Primer lectura

    '**************************************************

    rs.MoveFirst  '***** lee el primero

    FTotalizado = 0

    Guarda

    FIdEStado = rs("IdEstado")

    FIdFactura = rs("IdFactura")

    FIdEstadoAnterior = FIdEStado

    FIdFacturaAnterior = FIdFactura

    FMontoFactura = 0

    FQFactura = 0

    FMontoLote = 0

    FQLote = 0

    FMonto = 0

   ' EstadoFacturaDistintos

   

    Do While Not rs.EOF

        rs.MoveNext  '**** lee siguiente

        If rs.EOF Then

            EstadoFacturaDistintos

            LineaATabla

            Exit Do

        End If

        If Not rs.EOF Then FIdEStado = rs("IdEstado")

        If Not rs.EOF Then FIdFactura = rs("IdFactura")

       

        If FIdEStado = FIdEstadoAnterior And FIdFactura = FIdFacturaAnterior And Not rs.EOF Then

            ALote = ALote & vbCrLf & rs("Lote")

            AFechaVto = AFechaVto & vbCrLf & Nz(rs("FechaVto"))

            AMontoLote = CCur(AMontoLote) + rs("MontoLote")

            AQLote = CInt(AQLote) + rs("CantidadLote")

        End If

       

        If Not FIdEStado = FIdEstadoAnterior And Not FIdFactura = FIdFacturaAnterior And Not rs.EOF Then

           

            EstadoFacturaDistintos

            LineaATabla

            FMontoFactura = CCur(Nz(FMontoFactura, 0)) + CCur(AMontoFactura)

            FQFactura = CInt(FQFactura) + CInt(AQFactura)

            FIdEstadoAnterior = FIdEStado

            FIdFacturaAnterior = FIdFactura

        End If

        If Not FIdEStado = FIdEstadoAnterior And FIdFactura = FIdFacturaAnterior And Not rs.EOF Then

           

            IdemFactura

            LineaATabla

          

            FIdEstadoAnterior = FIdEStado

        End If

        If FIdEStado = FIdEstadoAnterior And Not FIdFactura = FIdFacturaAnterior And Not rs.EOF Then

           

            IdemEstado

            LineaATabla

            

            FIdFacturaAnterior = FIdFactura

        End If

    Loop

     'With myRange.Find

    With Nota.Content.Find

    .ClearFormatting

    .Replacement.ClearFormatting

    .Text = "#Totalizado#"

    .Replacement.Text = Format(FTotalizado, "##,##0.00")

    .Execute Replace:=wdReplaceAll

    End With

'*****************************************************************************

'Terminar

'*****************************************************************************

 

    Nota.SaveAs NombreArchivo

 

Salida:

'    Nota.Close

'    Set Nota = Nothing

    If vbYes = MsgBox("¿Cierra Word?", vbYesNo) Then

        Nota.Close

        Set Nota = Nothing

        Word.Quit

    End If

    Respuesta = CISave("NroNota", "OCOS", "IdOCO = " & IdOCO, NroNota)

    Exit Function

Errores:

    If Err.Number = 94 Then

        MsgBox "Falta completar datos: Nro remito, fecha etc completar y repetir la operación"

        Word.Quit

        Set Nota = Nothing

        Exit Function

    End If

    MsgBox Err.Number & " " & Err.Description

    Nota.Close

    Set Nota = Nothing

 

    Word.Quit

 

   NotaSimple = True

 

End Function

 

 

Public Sub LineaATabla()

    Tabla.Cell(Tabla.Rows.Count + Fila, 1).Range.InsertAfter FNroFactura

    Tabla.Cell(Tabla.Rows.Count + Fila, 2).Range.InsertAfter "$ " & Format(FMonto, "##,##0.00")

    Tabla.Cell(Tabla.Rows.Count + Fila, 3).Range.InsertAfter FDescripcion

    Tabla.Cell(Tabla.Rows.Count + Fila, 4).Range.InsertAfter FQ 'Cantidad

    Tabla.Cell(Tabla.Rows.Count + Fila, 5).Range.InsertAfter FAfiliado

    Tabla.Cell(Tabla.Rows.Count + Fila, 6).Range.InsertAfter FDelegacion

    Tabla.Cell(Tabla.Rows.Count + Fila, 7).Range.InsertAfter FNroRemito

    Tabla.Cell(Tabla.Rows.Count + Fila, 8).Range.InsertAfter FLote

    Tabla.Cell(Tabla.Rows.Count + Fila, 9).Range.InsertAfter FFechaVto

    Tabla.Cell(Tabla.Rows.Count + Fila, 10).Range.InsertAfter FRemitoFactura

    FTotalizado = Nz(CCur(FTotalizado), 0) + Nz(CCur(FMonto), 0)

    If Not rs.EOF Then Tabla.Rows.Add

End Sub

 


Public Sub LineaATabla()

    Tabla.Cell(Tabla.Rows.Count + Fila, 1).Range.InsertAfter FNroFactura

    Tabla.Cell(Tabla.Rows.Count + Fila, 2).Range.InsertAfter "$ " & Format(FMonto, "##,##0.00")

    Tabla.Cell(Tabla.Rows.Count + Fila, 3).Range.InsertAfter FDescripcion

    Tabla.Cell(Tabla.Rows.Count + Fila, 4).Range.InsertAfter FQ 'Cantidad

    Tabla.Cell(Tabla.Rows.Count + Fila, 5).Range.InsertAfter FAfiliado

    Tabla.Cell(Tabla.Rows.Count + Fila, 6).Range.InsertAfter FDelegacion

    Tabla.Cell(Tabla.Rows.Count + Fila, 7).Range.InsertAfter FNroRemito

    Tabla.Cell(Tabla.Rows.Count + Fila, 8).Range.InsertAfter FLote

    Tabla.Cell(Tabla.Rows.Count + Fila, 9).Range.InsertAfter FFechaVto

    Tabla.Cell(Tabla.Rows.Count + Fila, 10).Range.InsertAfter FRemitoFactura

    FTotalizado = Nz(CCur(FTotalizado), 0) + Nz(CCur(FMonto), 0)

    If Not rs.EOF Then Tabla.Rows.Add

End Sub

Poner en pie de página (de encabezado)

 

 

     ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter

     Selection.TypeText Text:="Nro Presupuesto: " & Format(IdSolicitud, "000")

     ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument


Cordialmente, Marciana
Saludos desde la Patagonia, Argentina
Arriba
Marciana Ver desplegable
Asiduo
Asiduo
Avatar

Unido: 20/Septiembre/2004
Localización: Argentina
Estado: Sin conexión
Puntos: 323
Enlace directo a este mensaje Enviado: 12/Junio/2019 a las 20:03
Deberás agregar una referencia a Microsoft Word nn.n Object library donde nn.n será la versión que tengas instalada.
Cordialmente, Marciana
Saludos desde la Patagonia, Argentina
Arriba
 Responder Responder
  Compartir tema   

Ir al foro Permisos de foro Ver desplegable