Creación de archivo aún existiendo el archivo vba
Tengo esta macro. Mi idea es que encuentre el archivo y copie la información y que si no lo encuentra lo cree. Sin embargo aún existiendo el archivo me está creando otro en el que pega la información.
Sub PORTADA()
Application.ScreenUpdating = False
'Abre word
Dim num As Variant
Dim ruta As String
'
num = Worksheets("Ficha").Range("F2").Value
ruta = "C:\Users\Laura\Dropbox\TODAS\"
'
'Buscar archivos en la ruta con el número
archi = Dir(ruta & "*" & num & "*.docx")
'
If archi <> "" Then
Set WordApp = CreateObject("word.Application")
'Abre archivo en la ruta y con el número
WordApp.Documents.Open ruta & archi
WordApp.Visible = True
'Titulo fecha
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
'Cerrar word
WordApp. Quit
Set WordApp = Nothing
Else
Dim TEX1 As String
Dim TEX2 As String
Dim TEX3 As String
TEX1 = 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 "C:\Users\Laura\Dropbox\TODAS\" & TEX2 & TEX3 & ".doc"
WordApp.Quit True
Set WordApp = Nothing
End If
Application.ScreenUpdating = True
End Sub
1 respuesta
Respuesta de Dante Amor
1
Estás segura que sí existe el archivo.
Ejecuta la macro paso a paso y revisa que efectivamente esté entrando a la parte inicial del If
If archi <> "" Then
Set WordApp = CreateObject("word.Application")
'Abre archivo en la ruta y con el número
WordApp.Documents.Open ruta & archi
WordApp.Visible = True
'Titulo fecha
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
'Cerrar word
WordApp. Quit
Set WordApp = Nothing
Realicé unas adecuaciones a tu código para que se vea más ordenado, depurando algunas líneas que no son necesarias y acomodando otras.
Prueba y me comentas.
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
'
'Ambiente
Application.ScreenUpdating = 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
Set WordApp = CreateObject("word.Application")
'Abre archivo EXISTENTE en la ruta y con el número
WordApp.Documents.Open ruta & archi
WordApp.Visible = True
'Titulo fecha
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
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
'
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub
¡Gracias! Me funcionó super bien..... SI fue raro lo sucedido; ya que según veo no estaba mal... Gracias por ayudarme con el orden del código.
.
'Encantado de ayudarte.
