Macro copiar celdas a diferentes libros de excel
Hola,
Mi intención es hacer una macro para copiar dos fórmulas que tengo en un libro a otros 300 que están en la misma carpeta.
La verdad es que si alguien puede ayudarme me ahorraría mucho trabajo.
Gracias,
Mi intención es hacer una macro para copiar dos fórmulas que tengo en un libro a otros 300 que están en la misma carpeta.
La verdad es que si alguien puede ayudarme me ahorraría mucho trabajo.
Gracias,
1 Respuesta
Respuesta de calvuch
1
Que celdas deseas copiar
Concretamente son las celdas P1 y P2. La intención es copiar estas celdas a los otros 300 libros con el mismo formato.
Gracias,
Gracias,
Ok entonces acá esta el macro:
Sub copiar_formulas()
Dim m As String
Dim i As Integer
Dim carpeta As String
Dim origen As String
'el presente macro copia formulas del libro activo a una serie de libros residentes en carpeta definida
'en variable carpeta
'calvuch 21092011
On Local Error GoTo errores
ChDir "C:\" ' cambia a directorio raiz
carpeta = "C:\Prueba\" ' establece la ruta de la carpeta contenedora de los *.xls
m = Dir(carpeta & "*.xls") ' concatena extension
i = 1 ' inicia indice del bucle
If m = "" Then
MsgBox "La ruta " & carpeta & " es incorrecta o no contiene archivos excel", vbExclamation, "Atención"
Exit Sub ' si no contiene archivos xls termina ejecucion
End If
origen = ActiveWorkbook.Name ' captura nombre del libro activo
Application.ScreenUpdating = False
'pasa formulas a los libros de primera instancia
Workbooks.Open Filename:=carpeta & m
Application.Workbooks(m).Sheets(1).Range("p1").Formula = Application.Workbooks(origen).Sheets(1).Range("p1").Formula
Application.Workbooks(m).Sheets(1).Range("p2").Formula = Application.Workbooks(origen).Sheets(1).Range("p2").Formula
ActiveWorkbook.Save ' GRABA LIBRO
ActiveWindow.Close ' CIERRA LIBRO
i = (i + 1)
Do Until m = ""
m = Dir ' sgte entrada del directorio
If m = "" Then Exit Do
Workbooks.Open Filename:=carpeta & m
Application.Workbooks(m).Sheets(1).Range("p1").Formula = Application.Workbooks(origen).Sheets(1).Range("p1").Formula
Application.Workbooks(m).Sheets(1).Range("p2").Formula = Application.Workbooks(origen).Sheets(1).Range("p2").Formula
ActiveWorkbook.Save ' GRABA LIBRO
ActiveWindow.Close ' CIERRA LIBRO
i = (i + 1)
DoEvents
Loop
Application.ScreenUpdating = True
MsgBox "Terminado", vbInformation
errores:
If Err.Number > 0 Then MsgBox Err.Number & " " & Err.Description, vbCritical, "Error"
End Sub
Debes insertarlo en un modulo, el macro se llama copiar_formulas
Consideraciones:
Debes modificar la ruta de la carpeta en donde están tus archivos, concretamente esta linea
carpeta = "C:\Prueba\" ' establece la ruta de la carpeta contenedora de los *.xls
Como ves yo utilice una carpeta llamada "Prueba" residente en el disco C:\
El libro origen del cual tomaremos los datos a copiar se asume como la hoja 1 del libro y los pasa también a la hoja 1 de cada libro en tu carpeta
Si tus datos están en otra hoja, solo basta modificar los indices en las lineas:
Application.Workbooks(m).Sheets(1).Range("p1").Formula = Application.Workbooks(origen).Sheets(1).Range("p1").Formula
En donde (1) es el indice de la hoja.
Una vez que pongas en ejecución el macro, debes esperar a que un mensaje en pantalla te indique que ha finalizado.
No olvides CERRAR la pregunta
Sub copiar_formulas()
Dim m As String
Dim i As Integer
Dim carpeta As String
Dim origen As String
'el presente macro copia formulas del libro activo a una serie de libros residentes en carpeta definida
'en variable carpeta
'calvuch 21092011
On Local Error GoTo errores
ChDir "C:\" ' cambia a directorio raiz
carpeta = "C:\Prueba\" ' establece la ruta de la carpeta contenedora de los *.xls
m = Dir(carpeta & "*.xls") ' concatena extension
i = 1 ' inicia indice del bucle
If m = "" Then
MsgBox "La ruta " & carpeta & " es incorrecta o no contiene archivos excel", vbExclamation, "Atención"
Exit Sub ' si no contiene archivos xls termina ejecucion
End If
origen = ActiveWorkbook.Name ' captura nombre del libro activo
Application.ScreenUpdating = False
'pasa formulas a los libros de primera instancia
Workbooks.Open Filename:=carpeta & m
Application.Workbooks(m).Sheets(1).Range("p1").Formula = Application.Workbooks(origen).Sheets(1).Range("p1").Formula
Application.Workbooks(m).Sheets(1).Range("p2").Formula = Application.Workbooks(origen).Sheets(1).Range("p2").Formula
ActiveWorkbook.Save ' GRABA LIBRO
ActiveWindow.Close ' CIERRA LIBRO
i = (i + 1)
Do Until m = ""
m = Dir ' sgte entrada del directorio
If m = "" Then Exit Do
Workbooks.Open Filename:=carpeta & m
Application.Workbooks(m).Sheets(1).Range("p1").Formula = Application.Workbooks(origen).Sheets(1).Range("p1").Formula
Application.Workbooks(m).Sheets(1).Range("p2").Formula = Application.Workbooks(origen).Sheets(1).Range("p2").Formula
ActiveWorkbook.Save ' GRABA LIBRO
ActiveWindow.Close ' CIERRA LIBRO
i = (i + 1)
DoEvents
Loop
Application.ScreenUpdating = True
MsgBox "Terminado", vbInformation
errores:
If Err.Number > 0 Then MsgBox Err.Number & " " & Err.Description, vbCritical, "Error"
End Sub
Debes insertarlo en un modulo, el macro se llama copiar_formulas
Consideraciones:
Debes modificar la ruta de la carpeta en donde están tus archivos, concretamente esta linea
carpeta = "C:\Prueba\" ' establece la ruta de la carpeta contenedora de los *.xls
Como ves yo utilice una carpeta llamada "Prueba" residente en el disco C:\
El libro origen del cual tomaremos los datos a copiar se asume como la hoja 1 del libro y los pasa también a la hoja 1 de cada libro en tu carpeta
Si tus datos están en otra hoja, solo basta modificar los indices en las lineas:
Application.Workbooks(m).Sheets(1).Range("p1").Formula = Application.Workbooks(origen).Sheets(1).Range("p1").Formula
En donde (1) es el indice de la hoja.
Una vez que pongas en ejecución el macro, debes esperar a que un mensaje en pantalla te indique que ha finalizado.
No olvides CERRAR la pregunta
