Como utilizar la nueva función de Excel FileSystemObject

Cuento con la función pero al pasar a excel 2010 ya no me funciona.

Me podrían ayudar?

Sub CopySheet()
Dim basebook As Workbook
Dim mybook As Workbook
Dim i As Long
Application.ScreenUpdating = False
Workbooks.Add
ChDir "C:\Macros\varios"
ActiveWorkbook.SaveAs Filename:= _
"C:\Macros\Final.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Range("A1").Select
ActiveCell.FormulaR1C1 = "canal"
Range("B1").Select
ActiveCell.FormulaR1C1 = "fecha"
Range("C1").Select
ActiveCell.FormulaR1C1 = "horario"
Range("D1").Select
ActiveCell.FormulaR1C1 = "marca"
With Application.FileSearch
'Application.FileSearch
.NewSearch
.LookIn = "C:\Macros\varios" ' Aquí esta el folder donde deben de estar los libros
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
Set basebook = ThisWorkbook
For i = 1 To .FoundFiles.Count
Set mybook = Workbooks.Open(.FoundFiles(i))
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Windows("Final.xls").Activate
Range("A2").Select
While ActiveCell.Value <> ""
ActiveCell.Offset(1, 0).Select
Wend
ActiveSheet.Paste
Next i
End If
End With
Columns("A:D").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Gracias

1 respuesta

Respuesta
1

No entendí. De la macro que pusiste, ¿cuál es el problema? Busqué la palabra FileSystemObject en tu macro y no la encuentro, ¿entonces qué necesitas?

Necesitas utilizar FileSystemObject, ¿para abrir los archivos?

Te anexo un ejemplo:

Sub abrirarchivo()
    Dim fso As FileSystemObject
    Dim myFile As file
    Dim mypath As String
    mypath = "C:\Macros\varios\"
    Set fso = New FileSystemObject
    For Each myFile In fso.GetFolder(mypath).Files
            Set mybook = Workbooks.Open(myFile)
            '
            'Aquí continua tu código
    Next
    Set fso = Nothing
End Sub

saludos.dam

Si es lo que necesitas.

Si disculpa no quedo bien claro, lo que utilizo es la función Application.FileSearch que en office 2010 ya no existe y fue reemplazada por FileSystemObject. Lo que hago con esta macro es abrir los archivos que hay en una carpeta y copiar parte de la información de los mismos en un nuevo archivo.

¿Probaste con el ejemplo que te puse? Solo agrega tu código donde dice ; aquí agrega tu código a partir de tu linea que dice: range("a2").select

Saludos. Dam

Inserte el código y sigo con inconvenientes

Sub abrirarchivo()
Dim fso As FileSystemObject
Dim myFile As file
Dim mypath As String
Dim basebook As Workbook
Dim mybook As Workbook
Dim i As Long
Application.ScreenUpdating = False
Workbooks.Add
ChDir "C:\Macros\varios"
ActiveWorkbook.SaveAs Filename:= _
"C:\Macros\Final.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Range("A1").Select
ActiveCell.FormulaR1C1 = "canal"
Range("B1").Select
ActiveCell.FormulaR1C1 = "fecha"
Range("C1").Select
ActiveCell.FormulaR1C1 = "horario"
Range("D1").Select
ActiveCell.FormulaR1C1 = "marca"
mypath = "C:\Macros\varios\"
Set FileSystemObject = New FileSystemObject
For Each myFile In fso.GetFolder(mypath).Files
Set mybook = Workbooks.Open(myFile)


If .Execute() > 0 Then '(Invalid or unqualified reference)

Set basebook = ThisWorkbook
For i = 1 To .FoundFiles.Count
Set mybook = Workbooks.Open(.FoundFiles(i))
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Windows("Final.xls").Activate
Range("A2").Select
While ActiveCell.Value <> ""
ActiveCell.Offset(1, 0).Select
Wend
ActiveSheet.Paste
Next i
End If
End With
Columns("A:D").EntireColumn.AutoFit
Application.ScreenUpdating = True
Next
Set fso = Nothing
End Sub

Me da el error que coloque entre paréntesis.

Gracias

Perdona no te dije bien cómo tenías que insertar tu código, ya realicé la integración, comenté las líneas que son de la versión anterior, por eso te envía error.

Sub CopySheet()
Dim basebook As Workbook
Dim mybook As Workbook
Dim i As Long
Application.ScreenUpdating = False
Workbooks.Add
ChDir "C:\Macros\varios"
ActiveWorkbook.SaveAs Filename:= _
"C:\Macros\Final.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Range("A1").Select
ActiveCell.FormulaR1C1 = "canal"
Range("B1").Select
ActiveCell.FormulaR1C1 = "fecha"
Range("C1").Select
ActiveCell.FormulaR1C1 = "horario"
Range("D1").Select
ActiveCell.FormulaR1C1 = "marca"
'With Application.FileSearch
'Application.FileSearch
'.NewSearch
'.LookIn = "C:\Macros\varios" ' Aquí esta el folder donde deben de estar los libros
'.SearchSubFolders = False
'.FileType = msoFileTypeExcelWorkbooks
'If .Execute() > 0 Then
Set basebook = ThisWorkbook
mypath = "C:\Macros\varios\"
    Set fso = New FileSystemObject
    For Each myFile In fso.GetFolder(mypath).Files
            Set mybook = Workbooks.Open(myFile)
            '
            'Aquí continua tu código
            'Set mybook = Workbooks.Open(.FoundFiles(i))
            Range("A2").Select
            Range(Selection, Selection.End(xlDown)).Select
            Range(Selection, Selection.End(xlToRight)).Select
            Selection.Copy
            Windows("Final.xls").Activate
            Range("A2").Select
            While ActiveCell.Value <> ""
            ActiveCell.Offset(1, 0).Select
            Wend
            ActiveSheet.Paste
    Next
'For i = 1 To .FoundFiles.Count
'Next i
'End If
'End With
Columns("A:D").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Si no te funciona con esta línea
mypath = "C:\Macros\varios\"
Prueba sin la última diagonal, así
mypath = "C:\Macros\varios"

Prueba y me comentas

Saludos. Dam
Si es lo que necesitas.

Excelente me funciono muy bien, igualmente fui por otra opción que me parecido mejor, si quieres te la envío. Lo que hace la misma es crear un archivo y va copiando la información en este. Lo bueno que tiene es que puedo hacer que le indique un nombre aq elección del usuario y carpeta destino también a elección.

Miiillll gracias por la ayuda ahora cuento con 2 formas de trabajar el inconveniente.

saludos

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas