Macro copia datos los traspone en otro y guarda una copia renombrandola con numero consecutivo

Tengo un libro "AGENDA16" con macro que copia datos y los traspone en otro libro "f16" pero necesito que esta misma macro guarde en una carpeta "FSI FICHERO" una copia de este libro nombrándolo con un numero consecutivo que se encuentra en la celda "G5" de la hoja f16 del mism

'ALFREDO PEREZ GUTIERREZ
'copia celdas seleccionadas y las pega en otro libro
 Sub CopiarCeldas()
 Application.ScreenUpdating = False
'Definir objetos a utilizar
Dim wbDestino As Workbook, _
    wsOrigen As Excel.Worksheet, _
    wsDestino As Excel.Worksheet, _
    rngOrigen As Excel.Range, _
    rngDestino As Excel.Range
'Indicar el libro de Excel destino
'Set wbDestino = Workbooks.Open(ActiveWorkbook.Path & "LIBRO1.xlsx")
Set wbDestino = Workbooks.Open(ActiveWorkbook.Path & "\fsi16.xlsm")
'Activar este libro
ThisWorkbook.Activate
'Indicar las hojas de origen y destino
Set wsOrigen = Worksheets("AGENDA16")
Set wsDestino = wbDestino.Worksheets("f16")
'Indicar la celda de origen y destino
Const celdaOrigen = "A1"
Const celdaDestino = "q4"
'Inicializar los rangos de origen y destino
Set rngOrigen = wsOrigen.Range(celdaOrigen)
Set rngDestino = wsDestino.Range(celdaDestino)
'Seleccionar rango de celdas origen
rngOrigen.Select
ActiveSheet.Range("u8:v21").Select
Selection.Copy
'Pegar datos en celda destino
rngDestino.PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Guardar y cerrar el libro de Excel destino
wbDestino.Save
'wbDestino.Close
End Sub

o libro gracias... Dejo aqui la macro

2 respuestas

Respuesta
1

.03/10/16

Buenas tardes, Alfredo

Sobre la base de tu código anterior hice los agregados necesarios para que haga lo que solicitas.

Prueba con esto:

'ALFREDO PEREZ GUTIERREZ
'copia celdas seleccionadas y las pega en otro libro
Sub CopiarCeldas()
'---- Variables modificables:
'ALFREDO, modifica estos datos de acuerdo a tu proyecto:
DirCopia = "C:\FSI FICHERO" 'carpeta donde grabar la copia
HojaNombre = "f16"
CeldaNombre = "G5"
Const celdaOrigen = "A1"
Const celdaDestino = "q4"
'---- fin Variables
'
'---- inicio de rutina:
'
DirCopia = DirCopia & IIf(Right(DirCopia, 1) = "\", "", "\")
NomArch = Sheets(HojaNombre).Range(CeldaNombre).Value
 Application.ScreenUpdating = False
'Definir objetos a utilizar
Dim wbDestino As Workbook, _
    wsOrigen As Excel.Worksheet, _
    wsDestino As Excel.Worksheet, _
    rngOrigen As Excel.Range, _
    rngDestino As Excel.Range
'Indicar el libro de Excel destino
'Set wbDestino = Workbooks.Open(ActiveWorkbook.Path & "LIBRO1.xlsx")
Set wbDestino = Workbooks.Open(ActiveWorkbook.Path & "\fsi16.xlsm")
'Activar este libro
ThisWorkbook.Activate
'Indicar las hojas de origen y destino
Set wsOrigen = Worksheets("AGENDA16")
Set wsDestino = wbDestino.Worksheets("f16")
'Indicar la celda de origen y destino
'Inicializar los rangos de origen y destino
Set rngOrigen = wsOrigen.Range(celdaOrigen)
Set rngDestino = wsDestino.Range(celdaDestino)
'Seleccionar rango de celdas origen
rngOrigen.Select
ActiveSheet.Range("u8:v21").Select
Selection.Copy
'Pegar datos en celda destino
rngDestino.PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Guardar y cerrar el libro de Excel destino
wbDestino.Save
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs DirCopia & NomArch & ".xlsx"
ActiveWorkbook.Close xlNo
Application.DisplayAlerts = True
Set rngOrigen = Nothing
Set rngDestino = Nothing
Set wsOrigen = Nothing
Set wsDestino = Nothing
Set wbDestino = Nothing
End Sub

Espero que sea lo que buscas.

Un abrazo

Fernando

(Buenos Aires, Argentina)

.

¿Buen día fernando gracias por tu apoyo ya cambie la macro por la que me envías pero me dice error de compilación que debo hacer?


                    

¿Te puedo enviar el libro de trabajo? Así sera más claro visualizar el problema

.

Hola, Alfredo

Hice una prueba parcial con la siguiente versión corregida de la rutina sin recibir error alguno:

'ALFREDO PEREZ GUTIERREZ
'copia celdas seleccionadas y las pega en otro libro  
Sub CopiarCeldas()
'---- Variables modificables:
'ALFREDO, modifica estos datos de acuerdo a tu proyecto:  
DirCopia = "C:\FSI FICHERO" 'carpeta donde grabar la copia
HojaNombre = "f16"
CeldaNombre = "G5"
Const celdaOrigen = "A1"
Const celdaDestino = "q4"
'---- fin Variables
'
'---- inicio de rutina:
'  
DirCopia = DirCopia & IIf(Right(DirCopia, 1) = "\", "", "\")
NomArch = Sheets(HojaNombre).Range(CeldaNombre).Value
 Application.ScreenUpdating = False
'Definir objetos a utilizar
Dim wbDestino As Workbook, _
    wsOrigen As Excel.Worksheet, _
    wsDestino As Excel.Worksheet, _
    rngOrigen As Excel.Range, _
    rngDestino As Excel.Range
'Indicar el libro de Excel destino
'Set wbDestino = Workbooks.Open(ActiveWorkbook.Path & "LIBRO1.xlsx")
Set wbDestino = Workbooks.Open(ActiveWorkbook.Path & "\fsi16.xlsm")
'Activar este libro
ThisWorkbook.Activate
'Indicar las hojas de origen y destino
Set wsOrigen = Worksheets("AGENDA16")
Set wsDestino = wbDestino.Worksheets("f16")
'Indicar la celda de origen y destino
'Inicializar los rangos de origen y destino
Set rngOrigen = wsOrigen.Range(celdaOrigen)
Set rngDestino = wsDestino.Range(celdaDestino)
'Seleccionar rango de celdas origen
rngOrigen.Select
ActiveSheet.Range("u8:v21").Select
Selection.Copy
'Pegar datos en celda destino
rngDestino.PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Guardar y cerrar el libro de Excel destino
wbDestino.Save
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs DirCopia & NomArch & ".xlsm"
Application.DisplayAlerts = True
Set rngOrigen = Nothing
Set rngDestino = Nothing
Set wsOrigen = Nothing
Set wsDestino = Nothing
Set wbDestino = Nothing
ActiveWorkbook.Close xlNo
End Sub

Prueba con ella. Si, eventualmente aún tuvieras problemas puedes enviarme el archivo

a:

.

Hola fer, disculpa mi ignorancia pero en la línea 16 si no me equivoco, donde dice NomArch = Sheets(HojaNombre).Range(CeldaNombre).Value

Me dice "error 9 en tiempo de ejecución:"

sub indice fuera del intervalo

Supongo que debo remplazar esos valores, intente pero aun muestra el mismo error

Los remplace por

NomArch = Sheets(f16).Range(G5).Value                y por este otro

NomArch = Sheets(agenda16).Range(G5).Value

¿Pero no logro que funcione que debo hacer cuales son los valores?

de nuevo mil gracias ...

Te envíe correo con los libros de trabajo, espero tus comentarios mil gracias...

.

Buenas, Alfredo

Había algunos errores de secuencia de instrucciones y el modo de llamar a las variables que arrojaban errores.

Prueba con esta versión corregida:

'ALFREDO PEREZ GUTIERREZ
'copia celdas seleccionadas y las pega en otro libro
Sub CopiarCeldas()
'---- Variables modificables:
'ALFREDO, modifica estos datos de acuerdo a tu proyecto:
DirCopia = "D:\CONTROL\CONTROL SERVITEC 2015\AGENDA PRE SERVICIO 2016\FSI FICHERO" 'carpeta donde grabar la copia
ArchivOrig = "fsi16.xlsm"
HojaNombre = "f16"
CeldaNombre = "f5"
Const celdaOrigen = "A1"
Const celdaDestino = "q4"
'---- fin Variables
'
'---- inicio de rutina:
'
Set wbDestino = Workbooks.Open(ActiveWorkbook.Path & "\" & ArchivOrig)
DirCopia = DirCopia & IIf(Right(DirCopia, 1) = "\", "", "\")
NomArch = Workbooks(ArchivOrig).Sheets(HojaNombre).Range(CeldaNombre).Value
 Application.ScreenUpdating = False
'Definir objetos a utilizar
Dim wbDestino As Workbook, _
    wsOrigen As Excel.Worksheet, _
    wsDestino As Excel.Worksheet, _
    rngOrigen As Excel.Range, _
    rngDestino As Excel.Range
'Indicar el libro de Excel destino
'Set wbDestino = Workbooks.Open(ActiveWorkbook.Path & "LIBRO1.xlsx")
'Activar este libro
ThisWorkbook.Activate
'Indicar las hojas de origen y destino
Set wsOrigen = Worksheets("AGENDA16")
Set wsDestino = wbDestino.Worksheets("f16")
'Indicar la celda de origen y destino
'Inicializar los rangos de origen y destino
Set rngOrigen = wsOrigen.Range(celdaOrigen)
Set rngDestino = wsDestino.Range(celdaDestino)
'Seleccionar rango de celdas origen
rngOrigen.Select
ActiveSheet.Range("u8:v21").Select
Selection.Copy
'Pegar datos en celda destino
rngDestino.PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Guardar y cerrar el libro de Excel destino
wbDestino.Save
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs DirCopia & NomArch & ".xlsm"
Application.DisplayAlerts = True
Set rngOrigen = Nothing
Set rngDestino = Nothing
Set wsOrigen = Nothing
Set wsDestino = Nothing
Set wbDestino = Nothing
ActiveWorkbook.Close xlNo
End Sub

Debería funcionar

Abrazo

Fer

.

Respuesta
1

Gracias por tu pronta respuesta, ¿me quedan unas dudas como direcciono la ubicación de la carpeta donde quiero guardar la copia?, ¿Puedo anidar la dirección en alguna celda de la misma hoja a guardar?

Podrías contar los archivos y agregar el con el num de archivos más 1

Fíjate en http://programarexcel si hay alguna macro que cuenta archivos no lo recuerdo.

¡Gracias! Voy a revisar elejemplo agradezco tu excelente disposición

Sub cta()
ChDir "C:\micarpeta\"
Set fso = CreateObject("scripting.filesystemobject")
Set carpeta = fso.getfolder(CurDir())
Set f = c.Files
For Each arc In f
cta = cta + 1
Next

End sub

Este ejemplo cta archivos sumas 1 y tienes el archivo siguiente.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas