SALAVERRINO

Buenos días  @Luis paz, gracias por el aporte brindado, el cual se soluciono, la primera opción de no aparecer la carpeta para guardar los PDF, sin embargo cuando comienza a imprimir los PDF de 1 en 1, se genera 1 solo archivo, pero solo esta guardando el ultimo registro asignado con el numero 98, pero los primeros registros no se muestran.

Saludos y espero comentarios.

99 Boletas.pdf

Buenas días a los integrantes de esté prestigioso Foro, en esta ocasión recurro a Uds para que me brinde su apoyo al guardar los archivos PDF, la siguiente macro lo encontré en un vídeo de youtube de ExceleInfo, el cual lo adapte a mi requerimiento, pero tengo algunos inconvenientes:

Macro original:

Option Explicit

Sub ElegirAccion()
Dim Elegir As Variant
Dim i As Integer
Dim miArchivo As String
Dim a As String
Dim Ruta As String
Dim intInicial As Integer
Dim intFinal As Integer
Dim intConsecutivo As Integer
Dim srtTitulo As String

srtTitulo = "EXCELeINFO"
intConsecutivo = ThisWorkbook.Sheets("Datos").Range("CONSECUTIVO").Value

Elegir = InputBox("Elige la acción a ejecutar:" & vbNewLine & "1 = Imprimir" & _
vbNewLine & "2 = Guardar en PDF", srtTitulo)

If Elegir <> 1 And Elegir <> 2 Then
    MsgBox "Debe elegir una opción correcta.", vbExclamation, srtTitulo
ElseIf Elegir = 1 Then
    
    intInicial = InputBox("Introduce el ID inicial", srtTitulo)
    intFinal = InputBox("Introduce el ID final", srtTitulo)
    
    If intFinal < intInicial Or intFinal > intConsecutivo Then
        MsgBox "Valida el ID final.", vbExclamation, srtTitulo
    Else
        For i = intInicial To intFinal
            
            ThisWorkbook.Sheets("Imprimir").Range("F4").Value = i
            MsgBox "Imprimiendo ID '" & i & "'. Presione Aceptar para continuar...", vbInformation, srtTitulo
            'ThisWorkbook.ActiveSheet.PrintOut Copies:=1
            
        Next i
    End If
    
ElseIf Elegir = 2 Then
    
    intInicial = InputBox("Introduce el ID inicial", srtTitulo)
    intFinal = InputBox("Introduce el ID final", srtTitulo)
    
    If intFinal < intInicial Or intFinal > intConsecutivo Then
        MsgBox "Valida el ID final.", vbExclamation, srtTitulo
    Else
        'Propiedad FileDialog
        With Application.FileDialog(msoFileDialogFolderPicker)
            .InitialFileName = ActiveWorkbook.Path & " \ "
            .Title = "EXCELeINFO - Seleccionar carpeta"
            .Show
            If .SelectedItems.Count = 0 Then
            Else
                Ruta = .SelectedItems(1)
                For i = intInicial To intFinal
                    
                    ThisWorkbook.Sheets("Imprimir").Range("F4").Value = i
                    
                    MsgBox "Guardando en PDF ID '" & i & "'. Presione Aceptar para continuar...", _
                    vbInformation, srtTitulo
                    
                    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                    Ruta & "\" & i & ".pdf", Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
                    
                Next i
            End If
        End With
    End If
End If
    
End Sub

Macro modificada:

Option Explicit
Sub ElegirAccion()
Dim i As Integer
Dim intInicial As Integer
Dim intFinal As Integer
Dim intConsecutivo As Integer
Dim srtTitulo As String
Dim Ruta As String

srtTitulo = "PRUEBITA"
intConsecutivo = ThisWorkbook.Sheets("BOLETA PDF").Range("CONSECUTIVO").Value

    intInicial = Sheets("BOLETA PDF").Range("N4")
    intFinal = Sheets("BOLETA PDF").Range("M3")
    
    If intFinal < intInicial Or intFinal > intConsecutivo Then
        MsgBox "Valida el ID final.", vbExclamation, srtTitulo
    Else
        With Application.FileDialog(msoFileDialogFolderPicker)
            .InitialFileName = ActiveWorkbook.Path & " \ "
            .Title = "EXCELeINFO - Seleccionar carpeta"
            .Show
            If .SelectedItems.Count = 0 Then
            Else
                Ruta = .SelectedItems(1)
                For i = intInicial To intFinal
                    
                    ThisWorkbook.Sheets("BOLETA PDF").Range("B5").Value = i
                    
                    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Ruta & "\" & i & " " & Sheets("BOLETA PDF").Range("I6") & ".pdf", _
                    Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
               Next i
            End If
        End With
    End If
End Sub

*Al estas en la pestaña BOLETAS PDF y al presionar el botón IMPRIMIR PDF me muestra la carpeta donde se guardara los datos pdf, y lo que quiera es que guarde los pdf sin necesidad que mencione y muestre la carpeta a guardar.

*Luego que se muestra la dirección a guardar los pdf, empiezan a generarse 1 x 1 cada ID (en esta ocasión son 98 registros de los cuales pueden ser más o menos) y lo que requiero es que se guarde en 1 solo archivos los 98 registros.

*También si fuera posible mediante otra macro, en lugar de ir guardando por el ID los 98 registros sea con nombres y apellidos, que se ubican en la celda O4 (opcional).

Adjunto link del archivo: https://drive.google.com/file/d/1ABlsmnrhXwBjLeLwYuTSi0_b1N_qWrqD/view?usp=sharing 

Desde ya agradezco tu apoyo.

Saludos.

Buenos días @avalencia @Gerson Pineda, por los aportes blindados y efectivamente es mucho mas factibles descargar el pdf y de ahi convertirlo a excel con diversos convertidores pdf, por lo que agradezco la atención y daría como TEMA SOLUCIONADO. 

Buenos días a los integrantes de este prestigioso foro, en ocasión recurro a Uds, para solicitar su aporte en una macro que permita convertir o extraer los datos del archivo pdf que se encuentran resaltados de color azul al excel bajo la estructura del confeccionado del mismo archivo que serán ubicados desde la celda B2.

Desde ya agradezco su apoyo y colaboración.

ARCHIVO PDF A EXCEL.xlsx IE_enero-2020.pdf

Buenas noches  a los integrantes @Snake @johnmpl @GabrielRaigosa por sus excelente aportes los cuales me ayudaron mucho en como unificar 2 fórmulas en 1 y a través de ese criterio las adapte a otras fórmulas, por lo que les agradezco su apoyo y colaboración, por lo que daría como TEMA SOLUCIONADO. 

Bendiciones. 

Buenas tardes a los integrantes del foro, en esta ocasión recurro a uds, para que brinde su apoyo en como unificar la formula siguiente

1º formula: REDONDEAR(SI(Y(A3<>"WEJ1";A3<>"WEJ2";A3<>"WEJ3");0;SI(B3>1000;C3*15%;0));2),

2º formula: REDONDEAR(SI(Y(A3<>"MEJ1";A3<>"MEJ2";A3<>"MEJ3");0;SI(B3>1000;C3*8%;0));2)

ya que actualmente la trabajo 2 celdas y luego sumo ambos resultados, como se aprecia en el siguiente archivo que adjunto, desde ya agradezco su apoyo y colaboración.

Saludos.

UNIFICAR FORMULA.xlsx

Buenos días @DiegoPC y @johnmpl por sus aportes brindados, el cual me ayudo mucho a mejorar el programa que actualmente vengo trabajando para el caso de los feriados.

Saludos y benciones, por lo que daria como TEMA SOLUCIONADO.

Buenas tardes @DiegoPC, casualmente eso es lo hago, pero la idea ver si hay alguna fórmula que pudiera hacerlo.

Gracias. 

Buenos dias a los integrantes de este prestigioso foro, en esta ocasión recurro a uds., para que me brinde su apoyo en cómo realizar el cambio automático del valor año de una determina fecha y que el cambio sea sobre la misma celda, es decir si tengo un valor en la celda B2 (01-01-18) se convierta automáticamente en (01-01-19) y así sucesivamente como se aprecia el resultado en la celda C2 y D2 para el próximo año, ya que por el momento tengo que estar reemplazando el valor del año, adjunto archivo para mejor detalle y esto es con el fin de realizar el cálculo de feriados.

Desde ya agradezco su atención por el apoyo.

AYUDA CON FORMULA FECHA.xlsx

Buenas tardes @isidrod los aportes me ayudaron mucho, por lo que daria TEMA SOLUCIONADO

Hola @johnmpl gracias por el aporte, por lo quedaría como TEMA SOLUCIONADO.

Gracias.

Buenas tardes a los integrantes de este prestigioso foro, en esta ocasion recurro a Uds, para que me ayuden con una formula, el cual me permita quitar el ultimo decimal como se aprecia en la celda D4 para asi obtener resultado final que se encuentra en la celda D4.

Desde ya agradezco su apoyo y colaboracion, adjunto archivo

Saludos

redondeos.xlsx

Buenos días a los integrantes de este foro, en esta ocasión requiero de su apoyo con una macro el cual me permita importar datos de un archivo (BASE DE DATOS  a otro archivo IMPORTA, sin que el archivo origen se abra, desde la fila A2, he encontrado varios ejemplos pero todos indican de un ruta especifica, para mi caso la ruta del archivo es variable, ya que los archivos están siempre ubicados en unidades distintas.

Desde ya agradezco su apoyo y colaboración.

BASE DE DATOS.xlsx IMPORTA.xlsx

Buenos días a los integrantes de este foro, en esta ocasión recurro a uds, para que brinde su apoyo en como mejorar la siguiente macro, lo que requiero es que me permita seleccionar la ruta donde se encuentra el archivo a utilizar, ya que esta macro ejecuta todos los archivos que se encuentran en dicha carpeta (previamente haber copiado todos los archivos a una carpeta determinada) y lo otro sería que si solo mostrara los archivos que empiecen con el nombre CONSOLIDADO xxxxxxxx.xlsm o CONSOLIDADO xxxxxxxx.xlsx, para lo cual adjunto archivos como ejemplos.

archivo principal: MUESTRA FORMULARIO.xlsm

Private Sub CommandButton2_Click()
    Dim ruta As String
    Dim fichero As String
    Dim wbOrigen As Workbook
    Dim uFO, uFD, uFF As Long
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False
    
    Set wbOrigen = ThisWorkbook
    
    ruta = ThisWorkbook.Path & "\"
    
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            fichero = ruta & ListBox1.List(i)
            Workbooks.Open (fichero)
            Sheets("PLANILLA").Activate
            uFO = Range("A" & Rows.Count).End(xlUp).Row
            uFD = wbOrigen.Sheets("PLANILLA").Range("C" & Rows.Count).End(xlUp).Row + 1
            
            Range("B8:BE" & uFO).Copy wbOrigen.Sheets("PLANILLA").Range("B" & uFD)
            ActiveWorkbook.Close (False)
            
        End If
    Next i
    
    Range("B8:BE8").Borders.LineStyle = xlContinuous
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.AskToUpdateLinks = True
    
    MsgBox "PROCESO TERMINADO"
    
End Sub

Dede ya agradezco su apoyo y coloración.

MUESTRA FORMULARIO.xlsm CONSOLIDADO CORDILLERA 24-7-2019 11-20-10 HRS.xlsx CONSOLIDADO ELITE FAITH 24-7-2019 16-45-53 HRS.xlsx

En 17/6/2019 at 14:53 , Gerson Pineda dijo:

Intenta realizar las modificaciones, para que de paso, aprendas mucho mas

 

Saludos

Buenas noches @Gerson Pineda desde ya agradezco el apoyo brindado, por lo que daria como tema solucionada.

Saludos.

Buenas tardes amigo @Gerson Pineda, la macro esta esta direccionando a la pestaña  RESUMEN mas no a la pestaña BOLETA que es la que debe imprimirse, nuevamente agraedezco el apoyo brindado, una nota adicional esta misma macro se puede acondicionar para que se imprima en PDF en forma masiva y con el nombre BOLETA.

Saludos.

Buenos tardes a los integrantes de este foro, en esta ocasión recurro a uds para solicitarle su apoyo y colaboración, en como mejorar esta macro, la cual me permite realizar una impresión de boleta de pago de 1 en 1 y ahora lo que requiero es que bajo este código puede grabarlo en PDF en forma masiva o si se puede grabar por cada DNI del trabajador, adjunto detalle:

En la Hoja PLANILLA, se encuentra la base de datos

En la Hoja RESUMEN, mediante una lista desplegable en la celda C1, se lograr filtra los DNI como valores únicos

En la Hoja BOLETA, mediante formulas se logra transponer los datos que deberán ser impreso por cada trabajar su remuneración de la lista desplegable.

Lo que se prende es que el valor de la celda C1 (lista desplegable de la hoja resumen) vayan variando de 1 en 1, para que en la hoja boleta se imprima trabajador por trabajador hasta el ultimo registro (DNI) de esa lista desplegable, espero haberme explicado lo que pretendo obtener como resultado.

Gracias por su apoyo y colaboración.

Option Explicit
 
Sub Imprimir()
    Dim Lin As Long
 
    Sheets(BOLETA).Select Lin = 8
 
    While Sheets(PLANILLA).Range(BS & Lin)  <> ""
        Sheets(RESUMEN).Range(C1) = Sheets(PLANILLA).Range(BS & Lin)
        DoEvents
        ActiveWindow.SelectedSheets.PrintOut _
                     Copies=2, _
                     Collate=True, _
                     IgnorePrintAreas=False
        Lin = Lin + 1
    Wend
End Sub

link de archivo (modulo)

https://drive.google.com/file/d/1uL1XaFLqIy2ShWiXOhvwsKI4YEBvnkmi/view?usp=sharing

Buenos días @Haplox desde agradezco el aporte brindado y era lo que esta requeriendo, por lo que daria como TEMA SOLUCIONADO.

Gracias.

Buenos días a los integrantes de este prestigioso foro, esta ocasión recurro a uds para que me ayuden con una macro o quizás mejorarla, la idea que tengo es extraer toda la información (conservando su formato) de la pestaña CONSOLIDADO y que se guarde automáticamente en la carpeta donde se está trabajando, el nombre del archivo que se extrae esta en hoja PLANILLA celda D2, fecha y hora y con la extensión “.xlsx” (CONSOLIDADO CYPRESS ARROW2 2-5-2019 18-20-56 HRS.xlsx), como se aprecia en la macro que describe a continuación.

Adjunto link de archivo.

https://drive.google.com/file/d/1_SVxDlLOyuGGmpIih5d-M4wYJSm6S7La/view?usp=sharing

Modulo 5:

Sub GuardarComo30072015()

Dim ncorr As String
With Application
.ScreenUpdating = False

NOMBRE = ThisWorkbook.Name
carpeta = ThisWorkbook.Path
filaa = carpeta & "\" & NOMBRE

ncorr = Format(Hoja1.Range("D2").Value, "000")

A = " " & Day(Date) & "-" & Month(Date) & "-" & Year(Date) & " " & Hour(Time) & "-" & Minute(Time) & "-" & Second(Time) & " HRS"

.DisplayAlerts = False
.EnableEvents = False
If nombrar = vbYes Then
    filab = carpeta & "\" & "plantilla electronica1"
    ActiveWorkbook.SaveAs Filename:=filab, FileFormat:=xlOpenXMLWorkbookMacroEnabled

Else
        filab = carpeta & "\" & "CONSOLIDADO " & ncorr & UCase(titulo) & A
        Call Elimina_hojas
        ActiveWorkbook.SaveAs Filename:=filab, FileFormat:=xlOpenXMLWorkbookMacroEnabled
        ActiveWorkbook.Close
End If
.EnableEvents = True
.DisplayAlerts = True

xnombre = ActiveWorkbook.Name
Workbooks.Open filaa
vuf = Range("B" & Rows.Count).End(xlUp).Row
Range("B8:AQ" & vuf).ClearContents
Workbooks(xnombre).Close

.ScreenUpdating = True
End With

End Sub

Sub Elimina_hojas()
Dim Vec, Elim, ws As Worksheet
'
Vec = Array("PLANILLA", "RESUMEN", "BOLETA", "CONSOLIDADO", "DATA", "EXPORTA", "REPORTE BOLETAS", "TELECREDITO JUDICIAL", "TELECREDITO", "DESCUENTO", "MENU", "SORT", "NAVI", "RECIBO", "TABLA AFP") ' Estas son las hojas que se mantienen.
'
ReDim Elim(0 To 0)
For Each ws In Worksheets
  If IsError(Application.Match(ws.Name, Vec, 0)) Then
    ReDim Preserve Elim(1 To 1 + UBound(Elim)): Elim(UBound(Elim)) = ws.Name
  End If
Next

Application.DisplayAlerts = False: On Error Resume Next
  Worksheets(Elim).Delete
On Error GoTo 0: Application.DisplayAlerts = True
MsgBox "Finalizando....."
Sheets("MENU").Activate
Range("B8").Select
End Sub

Desde ya agradezco su apoyo y colaboración.

Buenas tardes a los integrantes de este prestigioso foro, en esta ocasión recurro a uds para solicitar su apoyo en como mejorar las siguientes formulas que detallo a continuación:

Cita

FORMULA EN CELDA P2

Cuando la fórmula es evaluada

=SI(G2="";"";SI(O(G2=BASE_AUXILIAR!$B$8;G2=BASE_AUXILIAR!$B$9;G2=BASE_AUXILIAR!$B$10;G2=BASE_AUXILIAR!$B$11;G2=BASE_AUXILIAR!$B$12;G2=BASE_AUXILIAR!$B$13;G2=BASE_AUXILIAR!$B$14;G2=BASE_AUXILIAR!$B$15;G2=BASE_AUXILIAR!$B$16;G2=BASE_AUXILIAR!$B$17;G2=BASE_AUXILIAR!$B$18;G2=BASE_AUXILIAR!$B$19=BASE_AUXILIAR!$B$20=BASE_AUXILIAR!$B$21=BASE_AUXILIAR!$B$22=BASE_AUXILIAR!$B$23=BASE_AUXILIAR!$B$24=BASE_AUXILIAR!$B$25=BASE_AUXILIAR!$B$26=BASE_AUXILIAR!$B$27=BASE_AUXILIAR!$B$28=BASE_AUXILIAR!$B$29=BASE_AUXILIAR!$B$30=BASE_AUXILIAR!$B$31=BASE_AUXILIAR!$B$32=BASE_AUXILIAR!$B$33=BASE_AUXILIAR!$B$34=BASE_AUXILIAR!$B$35=BASE_AUXILIAR!$B$36=BASE_AUXILIAR!$B$37=BASE_AUXILIAR!$B$38=BASE_AUXILIAR!$B$39=BASE_AUXILIAR!$B$40=BASE_AUXILIAR!$B$41=BASE_AUXILIAR!$B$42=BASE_AUXILIAR!$B$43=BASE_AUXILIAR!$B$44=BASE_AUXILIAR!$B$45=BASE_AUXILIAR!$B$46=BASE_AUXILIAR!$B$47);0;E2))

G2 no contiene los criterios: 01: WINCHERO  (hoja base_auxiliar B2) -- 02: WINCHERO T (hoja base_auxiliar B3) -- 03: MURO (hoja base_auxiliar B4) -- 04: MURO T hoja base_auxiliar B5) -- 05 BODEGUERO (hoja base_auxiliar B6) -- 06 BODEGUERO T (hoja base_auxiliar B7)

Asigna el valor de la celda E2, y para el resto de criterios desde la hoja base_auxiliar (B8:B47) será 0 (cero)

formula desarrollada en celda Q2: =SI.ERROR(SI(G2="";"";SI(G2=AAA;BUSCARV(G2;BASE_AUXILIAR!$B$8:$B$47;1;FALSO);));E2)

Utilice:

Nombre de Rango: AAA (base_auxiliar D2:D7) y para BUSCARV (base_auxiliar B8:B47) y se hay mejor opción de mejora acepto ideas.

Cita

FORMULA EN CELDA S2

Cuando la fórmula es evaluada:

=SI(G2="";"";SI(O(G2=BASE_AUXILIAR!$B$2;G2=BASE_AUXILIAR!$B$4;G2=BASE_AUXILIAR!$B$6;G2=BASE_AUXILIAR!$B$8;G2=BASE_AUXILIAR!$B$9;G2=BASE_AUXILIAR!$B$10;G2=BASE_AUXILIAR!$B$11;G2=BASE_AUXILIAR!$B$12;G2=BASE_AUXILIAR!$B$13;G2=BASE_AUXILIAR!$B$14;G2=BASE_AUXILIAR!$B$15;G2=BASE_AUXILIAR!$B$16;G2=BASE_AUXILIAR!$B$17;G2=BASE_AUXILIAR!$B$18;G2=BASE_AUXILIAR!$B$19;G2=BASE_AUXILIAR!$B$20;G2=BASE_AUXILIAR!$BF$21;G2=BASE_AUXILIAR!$B$22;G2=BASE_AUXILIAR!$B$23;G2=BASE_AUXILIAR!$B$24;G2=BASE_AUXILIAR!$B$25;G2=BASE_AUXILIAR!$B$26;G2=BASE_AUXILIAR!$B$27;G2=BASE_AUXILIAR!$B$28;G2=BASE_AUXILIAR!$B$29;G2=BASE_AUXILIAR!$B$30;G2=BASE_AUXILIAR!$B$31;G2=BASE_AUXILIAR!$B$32;G2=BASE_AUXILIAR!$B$33;G2=BASE_AUXILIAR!$B$34;G2=BASE_AUXILIAR!$B$35;G2=BASE_AUXILIAR!$B$36;G2=BASE_AUXILIAR!$B$37;G2=BASE_AUXILIAR!$B$38;G2=BASE_AUXILIAR!$B$39;G2=BASE_AUXILIAR!$B$40;G2=BASE_AUXILIAR!$B$41;G2=BASE_AUXILIAR!$B$42;G2=BASE_AUXILIAR!$B$43;G2=BASE_AUXILIAR!$B$44;G2=BASE_AUXILIAR!$B$45;G2=BASE_AUXILIAR!$B$46;G2=BASE_AUXILIAR!$B$47);0;K2))

G2 contiene los criterios: 02: WINCHERO T (hoja base_auxiliar B3) -- 04: MURO T (hoja base_auxiliar B5) -- 06 BODEGUERO T (hoja base_auxiliar B7)

Asigna el valor de la celda K2, y para el resto de criterios desde la hoja base_auxiliar (B8:B47) será 0 (cero)

Y es ahí donde quisiera usar Función SI y Función BUSCARV como se aprecia la formula en celda S2 o quizás haya otro método.

FUNCION SI CON BUSCARV.xlsx

Buenos días @avalencia la PC la trabajo únicamente yo en modo personal, y lo que paso es actualizaron el windows y office automáticamente, y como indicas ahi fue el problema para ejecutarse la macro, la única forma sería desinstalar el office y volver a instalar y esperar que funcione el archivo y sino pasa nada ahi, ya seria windows.

Buenas noches @avalencia, adjunto link (imágenes) del error al ejecutar la macro, pero lo curioso es que estos archivos inicialmente se ejecuto en mi pc sin ningún problema con windows 10 (64 bits) y office 365 (32 bits) un aproximado de 2 semanas y luego ya comencé con los errores y por la tarde lo ejecute en otra maquina con windows 10 (64 bits) y office 2016 (32 bits) y si se ejecuto sin inconveniente alguno.

Saludos y espero comentarios.

https://drive.google.com/file/d/1bK2jAlIxr4kjOEYNrv7-zRLaZwGsVwKI/view?usp=sharing

https://drive.google.com/file/d/1W9rch6cetE7FP2laZHXiT0XuAI79aCe1/view?usp=sharing

Buenos días a los integrantes de este foro, en esta ocasión recurro a Uds, para que brinde su apoyo en como solucionar el ERROR en la siguiente instrucción que detallo, los archivos estuvieron trabajando sin ningún problema, pero haces 2 días comenzó con a fallar

Error ejecución.

Set objWord = CreateObject("Word.Application")

Siendo la macro original:

Sub tablaaword()
patharch = ThisWorkbook.Path & "\CARTA FAPOSA.docx"
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.documents.Add Template:=patharch, NewTemplate:=False, DocumentType:=0

Worksheets("TELECREDITO").Range("A1:D7").Select
Selection.Copy

textobuscar = "[tabla_excel]"

objWord.Selection.Move 6, -1 'moverse al principio del documento
objWord.Selection.Find.Execute FindText:=textobuscar

While objWord.Selection.Find.found = True 'reemplaza el texto, y busca si hay otro para reemplazarlo

objWord.Selection.PasteExcelTable False, True, False

objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=textobuscar
Wend

objWord.Activate

End Sub

Desde ya agradezco su apoyo y colaboración.

Saludos.

Hola @Haplox gracias por el aporte brindado el cual me ayudo mucho a tener una copia de lo que quería y conservando la misma información dentro del mismo archivo, porque había echo varios intentos y nada, lo único que gane es si tengo otro archivo abierto este se vuelve abrir por si solo y eso no es lo requerido, por lo que con esta solución daría como TEMA SOLUCIONADO.

Gracias.

Buenas tardes a los integrantes de este foro, pude solucionar el problema de como Combinar datos de Tabla de Excel a Word, para lo cual comparto la rutina.

Anterior:

Worksheets("TELECREDITO").Range("A1:D7").Select

Actual:

Worksheets("telecredito").Range("a1").CurrentRegion.Copy

por lo que daria como TEMA SOLUCIONADO.