Imprimir página | Cerrar ventana

Registros de Excel a Word...

Impreso de: Foro de Access y VBA
Categoría: Otros de Microsoft: Windows y Office
Nombre del foro: Excel
Descripción del foro: Foro de Excel y VBA de Excel
URL: http://www.mvp-access.com/foro/forum_posts.asp?TID=84490
Fecha de impresión: 17/Noviembre/2019 a las 06:41


Tema: Registros de Excel a Word...
Publicado por: John_Arnedo
Asunto: Registros de Excel a Word...
Fecha de publicación: 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



Respuestas:
Publicado por: Marciana
Fecha de publicación: 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


Publicado por: Marciana
Fecha de publicación: 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



Imprimir página | Cerrar ventana