............ Foro Excel
Si no lo has hecho aún: REGISTRATE!!!

Por Favor a podrían ayudar a complementar

Ver el tema anterior Ver el tema siguiente Ir abajo

Por Favor a podrían ayudar a complementar

Mensaje por cohispro el Lun Ene 28, 2013 10:57 pm

Encontré esta macro, me podrían ayudar a modificarla.

Esta macro me copias todas las hojas de varios libros que ya están en alguna carpeta, esta macro me abre el explorador y me pide que le indique la ruta y que seleccione los xls y posteriormente le cambia el nombre a la hoja.

Lo que yo quiero es que copie las hojas de todos los xls de una carpeta que esta en C:\proyecto\ y no les cambie el nombre a las hojas. (cada libro contiene una sola hoja).
Probé con otra macro que se llama juntar, pero se tarda mucho en procesar.

Esta macro ya la probé y es mucho mas rápida, solo que no me gusta que tenga que abrir el explorador y cambie los nombres.

Gracias de antemano.

Código:
Sub COPIADO()
Dim FILENAME As Variant
Dim iCantFiles As Integer, i As Integer, iCantHojas As Long
Dim wbkOrigen As Workbook
Dim wsh As Worksheet
FILENAME = Application.GetOpenFilename("Archivos Excel (*.xls), *.xls", , "Seleccione uno o mas archivos", , True)
If Not IsArray(FILENAME) Then
MsgBox "Tiene que elegir al menos un archivo a copiar", vbCritical
Exit Sub
End If
Application.ScreenUpdating = False
With ThisWorkbook
iCantFiles = UBound(FILENAME)
For i = 1 To iCantFiles
On Error Resume Next
Set wbkOrigen = Workbooks.Open(FILENAME(i))
If wbkOrigen Is Nothing Then Set wbkOrigen = Workbooks(i)
For Each wsh In wbkOrigen.Worksheets
iCantHojas = .Worksheets.Count
wsh.Copy After:=.Sheets(iCantHojas)
.Sheets(iCantHojas + 1).Name = "MT - " & CStr(iCantHojas + 1)
Next wsh
Application.DisplayAlerts = False
wbkOrigen.Close
Next i
End With
End Sub

cohispro

Masculino Cantidad de envíos : 3
Edad : 47
Ciudad - Pais : MEXICO
Version de Excel : 2003
Fecha de inscripción : 29/10/2012

Volver arriba Ir abajo

Re: Por Favor a podrían ayudar a complementar

Mensaje por GalileoGali el Dom Feb 03, 2013 9:35 am

Te recomiendo el uso de FileSystemObject para establecer la colección files dentro de C:\proyecto

Código:
Sub filesName()
Dim fso As FileSystemObject
Dim fl As File
Dim fold As Folder

Set fso = CreateObject("Scripting.FileSystemObject")
Set fold = fso.GetFolder("C:\Users\Galileogali\Desktop\Downloads")
 For Each fl In fold.Files
Debug.Print fl.Name
 Next fl
 End Sub


Para el tema Nombre identico para todas las hojas, No es posible que el nombre de una hoja en un libro esté reptida asi que si eliminas esta línea
Código:
.Sheets(iCantHojas + 1).Name = "MT - " & CStr(iCantHojas + 1)
y yo subiría el
Application.Displayalerts=false antes de del For each
Excel se ocupara de secuenciar los nombres de las hojas

_________________
GalileoGali
M.A.P. 2010-2013
Microsoft Active Professional
avatar
GalileoGali
Admin

Masculino Cantidad de envíos : 1963
Edad : 62
Ciudad - Pais : QUIROGA, Argentina
Version de Excel : 2000-2003-2007-2010
Fecha de inscripción : 24/01/2008

http://excelgali.mejorforo.net

Volver arriba Ir abajo

Gracias por responder

Mensaje por cohispro el Miér Feb 27, 2013 10:05 pm

GalileoGali realice las modificaciones recomendadas, pero aun me sigue saliendo la ventana en la que me pide que seleccione los xls.

La verdad no pude echar andar la macro "Te recomiendo el uso de FileSystemObject para establecer la colección files dentro de C:\proyecto", me sale un mensaje de error de compilación

Que tendría que quitar o adicionar para quitar la ventana y los xls los seleccione de una carpeta predeterminada.
lo único que pude hacer es:

Sub COPIADO()
Dim FILENAME As Variant
Dim iCantFiles As Integer, i As Integer, iCantHojas As Long
Dim wbkOrigen As Workbook
Dim wsh As Worksheet
FILENAME = Application.GetOpenFilename("Archivos Excel (*.xls), *.xls", , "Seleccione uno o mas archivos", , True)
If Not IsArray(FILENAME) Then
MsgBox "Tiene que elegir al menos un archivo a copiar", vbCritical
Exit Sub
End If
Application.ScreenUpdating = False
With ThisWorkbook
iCantFiles = UBound(FILENAME)
For i = 1 To iCantFiles
On Error Resume Next
Set wbkOrigen = Workbooks.Open(FILENAME(i))
If wbkOrigen Is Nothing Then Set wbkOrigen = Workbooks(i)
Application.DisplayAlerts = False
For Each wsh In wbkOrigen.Worksheets
iCantHojas = .Worksheets.Count
wsh.Copy After:=.Sheets(iCantHojas)
Next wsh
wbkOrigen.Close
Next i
End With
End Sub

cohispro

Masculino Cantidad de envíos : 3
Edad : 47
Ciudad - Pais : MEXICO
Version de Excel : 2003
Fecha de inscripción : 29/10/2012

Volver arriba Ir abajo

Re: Por Favor a podrían ayudar a complementar

Mensaje por Contenido patrocinado


Contenido patrocinado


Volver arriba Ir abajo

Ver el tema anterior Ver el tema siguiente Volver arriba


 
Permisos de este foro:
No puedes responder a temas en este foro.