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

.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...

Esto complementa lo que necesitas

Como trasponer datos

http://www.programarexcel.com/2014/08/como-trasponer-celdas-con-macro.html 

Macro que guarda la hoja activa

http://www.programarexcel.com/2015/11/macro-copia-hoja-activa-y-guarda-como.html 

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