Abrir un doc de word especifico o si esta abierto continuar

No se si es posible pero quisiera saber cómo podría hacerlo. Tengo una macro que me abre un documento de word específico; sin embargo en ocasiones este documento de word ya está abierto y al ejecutar la macro se bloquea todo excel.. Quisiera saber si existe una manera de que en la parte de que va a abrir el word, si está abierto simplemente lo ubique y continúe con la macro... Sin bloquearse.

1 respuesta

Respuesta
1

Prueba lo siguiente:

Sub PORTADA()
  'Declaración de variables
  Dim num As Variant
  Dim ruta As String, archi As String
  Dim TEX2 As String, TEX3 As String
  Dim WordApp As Object
  Dim wdDoc As Object
  'Dim WordApp As Word.Application
  'Dim wdDoc As Word.Document
  '
  'Ambiente
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  '
  'Buscar archivos en la ruta con el número
  num = Worksheets("Ficha").Range("F2").Value
  ruta = "C:\Users\Laura\Dropbox\TODAS\"
  archi = Dir(ruta & "*" & num & "*.docx")
  '
  If archi <> "" Then
    '
    'Verifica si el archivo está abierto
    On Error Resume Next
    Set WordApp = GetObject(, "Word.Application")
    On Error GoTo 0
    If WordApp Is Nothing Then
      Set WordApp = CreateObject("Word.Application")
    End If
    WordApp.Visible = True
    On Error Resume Next
    Set wdDoc = WordApp.Documents(ruta & archi)
    On Error GoTo 0
    If wdDoc Is Nothing Then
      'Abre el archivo
      Set wdDoc = WordApp.Documents.Open(ruta & archi)
    Else
      'activa el archivo
      WdDoc. Activate
    End If
    Sheets("PORTADA"). Range("D3:I34"). Copy
    'Se pegara en el documento lo copiado en la hoja de calculo
    WordApp. Selection. PasteAndFormat 13
    WordApp. Selection. InsertBreak
    WordApp. Selection.Move 6, -1
    WordApp.ActiveDocument.PrintOut Range:=2
    WordApp.Documents.Save True
  Else
    'crea nuevo archivo
    Sheets("PORTADA"). Range("D3:I34"). Copy
    TEX2 = ThisWorkbook.Worksheets("PORTADA").Range("M10").Value
    TEX3 = ThisWorkbook.Worksheets("PORTADA").Range("M11").Value
    Set WordApp = CreateObject("word.Application")
    WordApp. Documents. Add
    WordApp.Selection.PasteAndFormat 13
    WordApp.Selection.InsertBreak
    WordApp.Selection.Move 6, -1
    WordApp.ActiveDocument.PrintOut Range:=2 ' wdPrintCurrentPage
    WordApp.ActiveDocument.SaveAs ruta & TEX2 & TEX3 & ".doc"
  End If
  'Cerrar word
  'WordApp.Quit
  Set WordApp = Nothing
  Set wdDoc = Nothing
  '
  Application.ScreenUpdating = True
  Application.CutCopyMode = False
End Sub

Hola, te agradezco. Sin embargo, aunque me funciona me abre un documento nuevo de word y me aparece que el archivo esta bloqueado para edición de invitado. No sé como quitar eso... ya revisé de evarias maneras

Mira 

Sub GUARDAR()
Application.ScreenUpdating = False
'Abre word
  Dim num As Variant
  Dim ruta As String
  Dim TEX2 As String, TEX3 As String
  Dim WordApp As Object
  Dim wdDoc As Object
  'Dim WordApp As Word.Application
  'Dim wdDoc As Word.Document
  '
  'Ambiente
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
    '
  num = Worksheets("Ficha").Range("F2").Value
  ruta = "C:\Users\Laura\Dropbox\DOCUMENTOS PERSONALES\CONSULTORIO\hISTORIAS CLINICAS\TODAS\"
    '
  'Buscar archivos en la ruta con el número
  archi = Dir(ruta & "*" & num & "*.docx")
    '
  If archi <> "" Then
    'Verifica si el archivo está abierto
    On Error Resume Next
    Set WordApp = GetObject(, "Word.Application")
    On Error GoTo 0
    If WordApp Is Nothing Then
      Set WordApp = CreateObject("Word.Application")
    End If
    WordApp.Visible = True
    On Error Resume Next
    Set wdDoc = WordApp.Documents(ruta & archi)
    On Error GoTo 0
    If wdDoc Is Nothing Then
      'Abre el archivo
      Set wdDoc = WordApp.Documents.Open(ruta & archi)
    Else
      'activa el archivo
      wdDoc.Activate
    End If
     'Titulo fecha
    Sheets("Ficha").Range("B10").Copy
    'Se pegara en el documento lo copiado en la hoja de calculo
    WordApp.Selection.EndKey Unit:=6
    WordApp.Selection.PasteSpecial xlPasteAllExceptBorders
WordApp.Documents.Save
         'Cerrar word
    WordApp.Quit
    Set WordApp = Nothing
    Set wdDoc = Nothing
  Else
    'crea nuevo archivo
    Sheets("PORTADA").Range("D3:I34").Copy
    TEX2 = ThisWorkbook.Worksheets("PORTADA").Range("M10").Value
    TEX3 = ThisWorkbook.Worksheets("PORTADA").Range("M11").Value
    Set WordApp = CreateObject("word.Application")
    WordApp.Documents.Add
    WordApp.ActiveDocument.SaveAs ruta & TEX2 & TEX3 & ".doc"
       'Titulo fecha
    Sheets("Ficha").Range("B10").Copy
    'Se pegara en el documento lo copiado en la hoja de calculo
    WordApp.Selection.EndKey Unit:=6
    WordApp.Selection.PasteSpecial xlPasteAllExceptBorders
WordApp.Documents.Save
         'Cerrar word
    WordApp.Quit
    Set WordApp = Nothing
    Set wdDoc = Nothing
  End If
  Application.ScreenUpdating = True
 End Sub

En un caso me funcionó pero abrio el otro documento y salió el solo lectura, y en el otro no hizo nada... no pego la información

Cambiar esta línea

WordApp. Documents. Save

Por esta

WordApp. Documents. Save True

Ahora, probemos el caso cuando el archivo, sí existe y además está abierto.

Ejecuta la macro paso a paso con F8. También pon interrupciones:

Revisa exactamente por cuáles líneas pasa el código.

Si el archivo existe y además está abierto, debe pasar por esta línea:

WdDoc. Activate

Entonces analiza en qué momento te abre un nuevo libro. Si ya está abierto el archivo doc ya no debería abrir uno nuevo.

cuando llega a wdDoc. Activate me abre el archivo y sale esto

y el archivo estaba abierto 

Igualmente lo intenté con otro archivo y llega al mismo punto pero después ya no copia la información 

¿El archivo lo tienes compartido en la red?

¿Cuándo tienes abierto el archivo, lo puedes editar o solamente es de lectura?

Te hago todas esas preguntas, porque la macro que te puse, me funciona sin problema.

el archivo esta en Dropbox unicamente.... y sí puedo editarlo cuando esta abierto. Entiendo, te agradezco si puedo solucionarlo..

Incluso hay veces que me sale el mismo letrero cuando estoy editando el archivo me pide guardarlo nuevamente y es como un bucle guarda y otra vez pide lo mismo.

Tal vez es un conflicto en la versión de office y dropbox.

Intentaste probando con un archivo word pero que esté directamente en tu disco duro.

Ya acabo de probar así con el mismo archivo con una copia en mi escritorio directamente y sucedió lo mismo.. Pero cree uno nuevo y ahí si me funcionó... aunque me creo este archivo al lado ~$prueba.docx

Prueba con el siguiente código. Debes poner todo en el mismo módulo:

Sub PORTADA()
  'Declaración de variables
  Dim num As Variant
  Dim ruta As String, archi As String
  Dim TEX2 As String, TEX3 As String
  Dim WordApp As Object
  Dim wdDoc As Object
  'Dim WordApp As Word.Application
  'Dim wdDoc As Word.Document
  '
  'Ambiente
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  '
  'Buscar archivos en la ruta con el número
  num = Worksheets("Ficha").Range("F2").Value
  ruta = "C:\Users\Laura\Dropbox\TODAS\"
  archi = Dir(ruta & "*" & num & "*.docx")
  '
  If archi <> "" Then
    'Verifica si el archivo está abierto
    If IsFileOpen(ruta & archi) Then
      Set WordApp = GetObject(, "Word.Application")
      Set wdDoc = WordApp.Documents(ruta & archi)
      wdDoc.Activate
    Else
      Set WordApp = CreateObject("Word.Application")
      Set wdDoc = WordApp.Documents.Open(ruta & archi)
    End If
    Sheets("Ficha").Range("B10").Copy
    'Se pegara en el documento lo copiado en la hoja de calculo
    WordApp.Selection.EndKey Unit:=6
    WordApp.Selection.PasteSpecial xlPasteAllExceptBorders
    WordApp.Documents.Save True
  Else
    'crea nuevo archivo
    Sheets("Ficha").Range("B10").Copy
    TEX2 = ThisWorkbook.Worksheets("PORTADA").Range("M10").Value
    TEX3 = ThisWorkbook.Worksheets("PORTADA").Range("M11").Value
    Set WordApp = CreateObject("word.Application")
    WordApp.Documents.Add
    WordApp.Selection.EndKey Unit:=6
    WordApp.Selection.PasteSpecial xlPasteAllExceptBorders
    WordApp.ActiveDocument.SaveAs ruta & TEX2 & TEX3 & ".doc"
    WordApp.Quit
  End If
  'Cerrar word
  'WordApp.Quit
  Set WordApp = Nothing
  Set wdDoc = Nothing
  '
  Application.ScreenUpdating = True
  Application.CutCopyMode = False
End Sub
Function IsFileOpen(strFullPathFileName As String) As Boolean
'// VBA version to check if File is Open
'// We can use this for ANY FILE not just Excel!
'// Ivan F Moala
'// http://www.xcelfiles.com
Dim hdlFile As Long
    '// Error is generated if you try
    '// opening a File for ReadWrite lock >> MUST BE OPEN!
    On Error GoTo FileIsOpen:
    hdlFile = FreeFile
    Open strFullPathFileName For Random Access Read Write Lock Read Write As hdlFile
    IsFileOpen = False
    Close hdlFile
    Exit Function
FileIsOpen:
    '// Someone has it open!
    IsFileOpen = True
    Close hdlFile
End Function

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas

¿Cómo resolver num a letras en excel?

En un libro excel habilitado para macros al convertir números a letras, en lugar de aparecer el resultado esperado aparece el mensaje # ¿NOMBRE?.
1 respuesta

´No sé que fórmulas usar para resolverme el problema

La imagen no me la sube y tampoco veo como se sube un fichero, os intentaré explicar lo mejor que pueda mi problema. En una hoja Excel tengo hallados los pagos por formas de pago: SUMAR.SI(D1:D16;"Efectivo";B1:B16), y...
1 respuesta

¿Cómo usar un excel con macros desde varios ordenadores?

A tod@s! Tengo una aplicación en excel para introducir datos y visualizarlos con diferentes formularios creados. Lo que quiero hacer es: 1 Que ese libro este alojado en un sitio común y que lo puedan abrir desde varios ordenadores. 2º Que se pueda...
3 respuestas

Error en macro al ejecutar el botón aceptar

Necesitaría la colaboración para resolver el error que sucede al ejecutar el botón aceptar Set mifila = Hoja2.ListObjects(1).ListRows.Add Lo que yo agregue solamente a la base fue una columna al inicio ("A") anteriormente se llamaba Tabla6 y yo ahora...
1 respuesta

Detectar cambios en tabla dinámica

Tengo una hoja donde se van actualizando datos mediante una tabla dinámica. ¿Cómo detecto cuando se producen cambios (sólo en la parte de la tabla dinámica) para ejecutar otra macro en la misma hoja?
1 respuesta

Macro con combinación de teclas

Acudo aquí buscando ayuda, ¿Cómo crear una macro que genere una combinación de teclas? NO se trata de asignar una macro a una combinación de teclas, es todo lo contrario. El problema radica en que tengo una macro que rellena ciertas celdas con...
1 respuesta

Pasar datos de listbox a hoja con decimales

Como están estimados maestros y maestras, una vez mas solicitando vuestra experta ayuda. Tengo un formulario que busca datos entre 2 fechas desde 2 textbox, carga en listbox lo filtrado, en la columna 2 del listbox carga valores con formato de 2...
1 respuesta

Una macro que de aviso sobre vencimiento de una cedula de identidad

Tengo una hoja de calculo de 6 columnas en donde la columna A es fecha de vencimiento, las columnas B, C, y D son apellidos paterno, Materno u nombres, la columna E es el numero de cedula de identidad Con Formato ##.###.###-# la columna F es lo...
1 respuesta

Error decimales en hoja de excel

Tengo un albarán de varios productos que no vienen desglosado el iva En una hoja Excel introduzco el precio, con la formula sumar el precio lo desgloso en base imponible y el iva paracque me dé el precio del producto pero cuando sumo el total de...
4 respuestas

Filtrar información y luego pasar a otro libro

Tengo una macro que copia y pega del libro llamado Origen y Hoja1, dónde este está cerrado, al libro Destino y Hoja 2 de la siguiente manera: Sub importar() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual...
1 respuesta