Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target.Row > 5 Then
If Target.Row = 6 Then
Sheets("hoja1").Cells(Target.Row, 2).Value = 1
Sheets("hoja1").Cells(Target.Row, 10).Value = Now
Sheets("hoja1").Cells(Target.Row, 4).Value = Name
Else
Sheets("hoja1").Cells(Target.Row, 2).Value = Sheets("hoja1").Cells(Target.Row - 1, 2).Value + 1
Sheets("hoja1").Cells(Target.Row, 10).Value = Now
Sheets("hoja1").Cells(Target.Row, 4).Value = Name
End If
End If
End Sub
Sub transferir()
Dim NombreArchivo As String
Dim ultimafila As Long
Dim cont As Long
Dim palabraBusqueda As String
palabraBusqueda = Sheets("Hoja4").Cells(2, 6)
palabraBusqueda = "*" & palabraBusqueda & "*"
End SubSub transferir()
Dim NombreArchivo As String
Dim ultimafila As Long
Dim cont As Long
Dim palabraBusqueda As String
palabraBusqueda = Sheets("Hoja4").Cells(2, 6)
palabraBusqueda = "*" & palabraBusqueda & "*"
End Sub
Sub duplicados()
Dim valor As Long
Sheets("Hoja2").Range("A2").Select
Do While Not IsEmpty(activecell)
valor = Application.WorksheetFunction.CountIf(Range("A:A"), activecell.value)
If valor > 1 Then
activecell.EntireRow.Delete
Else
activecell.Offset(1, 0).Select
End If
Loop
End Sub
Option Explicit
Private Sub worksheet_SelectionChange(ByVal target As Range)
If target.Column = 1 And target.row > 1 Then
If target.row = 2 Then
Sheets("hoja2").Cells(target.row, 2).Value = 1
Else
Sheets("hoja2").Cells(target.row, 2).Value = Sheets("hoja2").Cells(target.row - 1, 2).Value + 1
End If
End If
End Sub
Sub indexar()
Dim celda As Object
Dim i As Integer
Set unicos = New Collection
'loop en todas las celdas y agregarlas
For Each celda In Range("A2:A600")
'cuando encuentra un item repetido, da error
'que salvamos con la instrucción on error resume next
On Error Resume Next
'la funcion agregara codigos no repetidos
'objeto add item, key, before, after
unicos.Add celda.Value, CStr(celda.Value)
On Error GoTo 0
Next celda
'escribir codigos unicos
For i = 1 To unicos.Count
Sheets("Hoja2").Range("B2:B600").Offset(i - 1, 0).Value = unicos(i)
Next i
End Sub
Dim xDic As New Dictionary
Private Sub worksheet_SelectionChange(ByVal target As Range)
Dim xCell As Range
Dim xRg As Range
Set xRg = Range("E1:F600")
If xDic.Count <> xRg.Count Then
For Each xCell In xRg
xDic.Add xCell.Address, xCell.FormulaR1C1
Next
End If
If (target.Count = 1) And (Not Application.Intersect(xRg, target) Is Nothing) And (target.HasFormula) Then
With target
.Value = .Value
End With
Else
For Each xCell In xRg
xCell.Formula = xDic.Item(xCell.Address)
Next
End If
End Sub
'This function loops through all the files in the folder and
'gets the properties of each file and displays them on the sheet
Public Sub GetFileProperties()
'Variable Declaration
Dim objFS As Object
Dim objFile As Object
Dim strPath As String
Dim vFile As Variant
Dim iCurRow As Integer
'Clear old data from the sheet
Sheet1.Range("C7:H" & Sheet1.Rows.Count).ClearContents
'Set the path of the folder
strPath = Sheet1.Range("C3").Value
'Add slash at the end of the path
If Right(strPath, 1) <> "/" And Right(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
'Set Directory to folder path
'Change or add formats to get specific file types
'Set the variable to FileSystemObject
Set objFS = CreateObject("Scripting.FileSystemObject")
iCurRow = 7
Do While vFile <> "" 'LOOP until all files in folder strPath have been looped through
Set objFile = objFS.getfile(vFile)
'File name
Sheet1.Cells(iCurRow, 3).Value = objFile.Name
'Date Created
Sheet1.Cells(iCurRow, 4).Value = objFile.DateCreated
'Date Last Accessed
Sheet1.Cells(iCurRow, 5).Value = objFile.DateLastAccessed
'Date Last Modified
Sheet1.Cells(iCurRow, 6).Value = objFile.DateLastModified
'Type
Sheet1.Cells(iCurRow, 8).Value = objFile.Type
vFile = Dir
iCurRow = iCurRow + 1
Loop
End Sub
Option Explicit
Sub GetFileNames()
Dim fila As Long
Dim Ruta_elegida, Nombre_archivo, Ruta_inicial
Ruta_inicial = "C:\" '<<< Donde comienzo a mirar
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Selecciona una carpeta"
.InitialFileName = Ruta_inicial
.Show
If .SelectedItems.Count <> 0 Then 'Compruebo que se ha seleccionado una carpeta
Ruta_elegida = .SelectedItems(1) & "\" 'Ruta que he elegido
Nombre_archivo = Dir(Ruta_elegida) 'primer archivo de la carpeta
Do While Nombre_archivo <> ""
Cells(7, 1).Offset(fila) = Nombre_archivo
fila = fila + 1
Nombre_archivo = Dir 'siguiente archivo
Loop
End If
End With
End Sub
Sub nuevo2()
Dim wb As Workbook
Dim ws_entradas As Worksheet
Dim ws_resumen As Worksheet
Set wb = ActiveWorkbook
Set ws_entradas = wb.Sheets("Hoja1")
Set ws_resumen = wb.Sheets("Hoja2")
Dim r_suma As Range
Set r_suma = Range(ws_entradas.Cells(8, 10), ws_entradas.Cells(60000, 10))
r_suma = Application.WorksheetFunction.Sum(ws_entradas.Cells(8, 10), ws_entradas.Cells(60000, 10))
i = suma + 1
n=0
m=0
For cu = i To 60000
If ws_entradas.Cells(cu, 2) <> "" Then
n=n+1
End If
Next cu
For re = 1 To 60000
If ws_resumen.Cells(re, 2) <> "" Then
m=m+1
End If
Next re
If n > 0 Then
Set rang_copia = Range(ws_entradas.Cells(i, 7), ws_entradas.Cells(i + n, 7))
rang_copia.Copy _
Destination:=ws_resumen.Cells(m, 9)
End If
End Sub
Sub nuevo()
Dim wb As Workbook
Dim ws_entradas As Worksheet
Dim ws_resumen As Worksheet
Set wb = ActiveWorkbook
Set ws_entradas = wb.Sheets("Hoja1")
Set ws_resumen = wb.Sheets("Hoja2")
Dim r_suma As Range
Set r_suma = Range(ws_entradas.Cells(1, 10), ws_entradas.Cells(60000, 10))
r_suma = Application.WorksheetFunction.Sum(ws_entradas.Cells(1, 10), ws_entradas.Cells(60000, 10))
i = suma + 1
n=0
m=0
For cu = i To 60000
If ws_entradas.Cells(cu, 2) <> "" Then
n=n+1
End If
Next cu
For re = 1 To 60000
If ws_resumen.Cells(re, 2) <> "" Then
m=m+1
End If
Next re
If n > 0 Then
Set rang_copia = Range(ws_entradas.Cells(i, 2), ws_entradas.Cells(i + n, 2))
rang_copia.Copy _
Destination:=ws_resumen.Cells(m, 1)
End If
End Sub
Sub documemts()
Dim busqueda As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheets("Hoja4")
Set ws2 = Sheets("Hoja2")
ws1.Visible = True
ws1.Activate
counter0 = 0
For i = 2 To 30
If ws1.Cells(i, 6) <> "" Then
counter0 = counter0 + 1
End If
Next i
ws2.Visible = True
ws2.Activate
counter1 = 0
For j = 1 To 150
ws2.Cells(j, 1).Select
If ws2.Cells(j, 2) <> "" Then
counter1 = counter1 + 1
End If
Next j
For k = 2 To counter0 + 1
For l = 2 To counter1 + 1
If Left(ws2.Cells(l, l), 2) = ws1.Cells(k, 6) Then
If Cells(l, 14) = "" Or Cells(l, 14) = "No" Then
Cells(l, 14) = "No"
End If
End If
If Left(ws2.Cells(1, l), 2) <> ws1.Cells(k, 6) Then
If Cells(l, 14) = "" Or Cells(l, 14) = "No" Then
Cells(l, 14) = "No"
End If
End If
Next l
Next k
Z=2
While ws2.Cells(Z, 1) <> ""
ws2.Cells(Z, 14).Select
If ws2.Cells(Z, 14) = "No" Then
Selection.EntireRow.Delete
Z=1
End If
Z=Z+1
Wend
End Sub
Public X()
Public i As Long
Public objShell, objFolder, objFolderItem
Public FSO, oFolder, Fil
Sub MainExtractData()
Dim NewSht As Worksheet
Dim MainFolderName As String
ReDim X(1 To 65536, 1 To 11)
Set objShell = CreateObject("Shell.Application")
Application.ScreenUpdating = False
MainFolderName = BrowseForFolder()
Set NewSht = ThisWorkbook.Sheets.Add
X(1, 1) = "Ruta"
X(1, 2) = "Nombre archivo"
X(1, 3) = "Ultima modificación"
X(1, 4) = "Fecha creación"
X(1, 5) = "Autor"
i=1
Set FSO = CreateObject("scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(MainFolderName)
'error handling to stop the obscure error that occurs at time when retrieving DateLastAccessed
On Error Resume Next
For Each Fil In oFolder.Files
Set objFolder = objShell.Namespace(oFolder.Path)
Set objFolderItem = objFolder.ParseName(Fil.Name)
i=i+1
If i Mod 20 = 0 And TimeLimit <> 0 And Timer > (TimeLimit * 60 + StartTime) Then
GoTo FastExit
End If
If i Mod 50 = 0 Then
Application.StatusBar = "Processing File " & i
DoEvents
End If
X(i, 1) = oFolder.Path
X(i, 2) = Fil.Name
X(i, 3) = Fil.DateLastAccessed
X(i, 4) = Fil.DateLastModified
X(i, 5) = Fil.DateCreated
X(i, 6) = Fil.Type
X(i, 7) = Fil.Size
X(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
Next
'Get subdirectories
If TimeLimit = 0 Then
Call RecursiveFolder(oFolder, 0)
Else
If Timer < (TimeLimit * 60 + StartTime) Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime)
End If
FastExit:
Range("A:K") = X
If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete
Range("A:K").WrapText = False
Range("A:K").EntireColumn.AutoFit
Range("1:1").Font.Bold = True
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Range("a1").Activate Set FSO = Nothing
Set objShell = Nothing
Set oFolder = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
Set Fil = Nothing
Application.StatusBar = ""
Application.ScreenUpdating = True
End Sub
Sub RecursiveFolder(xFolder, TimeTest As Long)
Dim SubFld
For Each SubFld In xFolder.SubFolders
Set oFolder = FSO.GetFolder(SubFld)
Set objFolder = objShell.Namespace(SubFld.Path)
For Each Fil In SubFld.Files
Set objFolder = objShell.Namespace(oFolder.Path)
'Problem with objFolder at times
If Not objFolder Is Nothing Then
Set objFolderItem = objFolder.ParseName(Fil.Name)
i=i+1
If i Mod 20 = 0 And TimeTest <> 0 And Timer > TimeTest Then
Exit Sub
End If
If i Mod 50 = 0 Then
Application.StatusBar = "Processing File " & i
DoEvents
Sheets(“hoja1”).select
End If
X(i, 1) = SubFld.Path
X(i, 2) = Fil.Name
X(i, 3) = Fil.DateLastAccessed
X(i, 4) = Fil.DateLastModified
X(i, 5) = Fil.DateCreated
X(i, 6) = Fil.Type
X(i, 7) = Fil.Size
X(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
Else
Debug.Print Fil.Path & " " & Fil.Name
End If
Next
Call RecursiveFolder(SubFld, TimeTest)
Next
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target.Row > 1 Then
If Target.Row = 2 Then
Dim NewSht As Worksheet
Dim MainFolderName As String
Dim TimeLimit As Long, StartTime As Double
ReDim X(1 To 65536, 1 To 11)
Set objShell = CreateObject("Shell.Application")
Application.ScreenUpdating = False
MainFolderName = BrowseForFolder()
Set NewSht = ThisWorkbook.Sheets.Add
X(1, 1) = "Ruta"
X(1, 2) = "Indexación"
X(1, 3) = "Nombre archivo"
X(1, 4) = "Producto"
X(1, 5) = "Tipo producto"
X(1, 7) = "Fecha modificación"
X(1, 8) = "Descripción"
X(1, 9) = "Creación"
X(1, 6) = "Autor"
X(1, 10) = "Razón actualización"
i=1
Set FSO = CreateObject("scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(MainFolderName)
'error handling to stop the obscure error that occurs at time when retrieving DateLastAccessed
On Error Resume Next
For Each Fil In oFolder.Files
Set objFolder = objShell.Namespace(oFolder.path)
Set objFolderItem = objFolder.ParseName(Fil.Name)
i=i+1
If i Mod 20 = 0 And TimeLimit <> 0 And Timer > (TimeLimit * 60 + StartTime) Then
GoTo FastExit
End If
If i Mod 50 = 0 Then
Application.StatusBar = "Processing File " & i
DoEvents
End If
X(2, 1) = oFolder.path
X(2, 3) = Fil.Name
X(2, 7) = Fil.dateLastModified
X(2, 9) = Fil.DateCreated
Next
'Get subdirectories
If TimeLimit = 0 Then
Call RecursiveFolder(oFolder, 0)
Else
If Timer < (TimeLimit * 60 + StartTime) Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime)
End If
FastExit:
Range("A:K") = X
If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete
Range("A:K").WrapText = False
Range("A:K").EntireColumn.AutoFit
Range("1:1").Font.Bold = True
Rows("2:2").Select
End If
Set FSO = Nothing
Set objShell = Nothing
Set oFolder = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
Set Fil = Nothing
Application.StatusBar = ""
Application.ScreenUpdating = False
End If
End Sub
Sub RecursiveFolder(xFolder, TimeTest As Long)
Dim SubFld
For Each SubFld In xFolder.SubFolders
Set oFolder = FSO.GetFolder(SubFld)
Set objFolder = objShell.Namespace(SubFld.path)
For Each Fil In SubFld.Files
Set objFolder = objShell.Namespace(oFolder.path)
'Problem with objFolder at times
If Not objFolder Is Nothing Then
Set objFolderItem = objFolder.ParseName(Fil.Name)
i=i+1
If i Mod 20 = 0 And TimeTest <> 0 And Timer > TimeTest Then
Exit Sub
End If
If i Mod 50 = 0 Then
Application.StatusBar = "Processing File " & i
DoEvents
End If
X(1, 1) = oFolder.path
X(1, 2) = objFolder.GetDetailsOf(objFolderItem, 2)
X(1, 3) = Fil.Name
X(1, 4) = objFolder.GetDetailsOf(objFolderItem, 4)
X(1, 5) = objFolder.GetDetailsOf(objFolderItem, 5)
X(1, 7) = Fil.dateLastModified
X(1, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
X(1, 9) = Fil.DateCreated
X(1, 6) = "objFolder.GetDetailsOf(objFolderItem, 6)"
X(1, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
i=1
Else
Debug.Print Fil.path & " " & Fil.Name
End If
Next
Call RecursiveFolder(SubFld, TimeTest)
Next
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
Public X()
Public i As Long
Public objShell, objFolder, objFolderItem
Public FSO, oFolder, Fil
Sub MainExtractData()
Dim NewSht As Worksheet
Dim MainFolderName As String
ReDim X(1 To 65536, 1 To 11)
Set objShell = CreateObject("Shell.Application")
MainFolderName = BrowseForFolder()
Sheets("hoja1").Select
X(1, 1) = "Ruta"
X(1, 2) = "Nombre archivo"
X(1, 3) = "numero"
X(1, 7) = "Fecha modificación"
X(1, 9) = "Creación"
X(1, 6) = "Autor"
i=1
Set FSO = CreateObject("scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(MainFolderName)
'error handling to stop the obscure error that occurs at time when retrieving DateLastAccessed
On Error Resume Next
For Each Fil In oFolder.Files
Set objFolder = objShell.Namespace(oFolder.path)
Set objFolderItem = objFolder.ParseName(Fil.Name)
i=i+1
If i Mod 50 = 0 Then
Application.StatusBar = "Processing File " & i
DoEvents
End If
X(i, 1) = oFolder.path
X(i, 2) = Fil.Name
X(i, 7) = Fil.dateLastModified
X(i, 9) = Fil.DateCreated
Next
'Get subdirectories
FastExit:
Range("A:K") = X
If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete
Range("A:K").WrapText = True
Range("A:K").EntireColumn.AutoFit
Range("1:1").Font.Bold = True
Rows("2:2").Select
Set FSO = Nothing
Set objShell = Nothing
Set oFolder = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
Set Fil = Nothing
Application.StatusBar = ""
Sheets("hoja1").Select
End Sub
Sub RecursiveFolder(xFolder, TimeTest As Long)
Dim SubFld
For Each SubFld In xFolder.SubFolders
Set oFolder = FSO.GetFolder(SubFld)
Set objFolder = objShell.Namespace(SubFld.path)
Sheets("hoja1").Select
For Each Fil In SubFld.Files
Set objFolder = objShell.Namespace(oFolder.path)
'Problem with objFolder at times
If Not objFolder Is Nothing Then
Set objFolderItem = objFolder.ParseName(Fil.Name)
i=i+1
If i Mod 20 = 0 And TimeTest <> 0 And Timer > TimeTest Then
Exit Sub
End If
If i Mod 50 = 0 Then
Application.StatusBar = "Processing File " & i
DoEvents
End If
X(i, 1) = SubFld.path
X(i, 2) = Fil.Name
X(i, 7) = Fil.dateLastModified
X(i, 9) = Fil.DateCreated
Else
Debug.Print Fil.path & " " & Fil.Name
End If
Next
Call RecursiveFolder(SubFld, TimeTest)
Next
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
Sub ListarPropiedadesFicherosCarpeta()
Dim Ruta As String
'Creamos el objeto FileSystemObject que
'proporciona acceso al sistema de archivos de un equipo
Set FSO = CreateObject("Scripting.FileSystemObject")
'Indicamos la ruta de donde vamos a obtener
'los ficheros, en este caso D:\BancoFotos
Ruta = "D:\María jose delgado\CARPETA"
'definimos dos variables que necesitaremos,
'para recuperar el nombre de la carpeta, y los ficheros que haya dentro
Set Carpeta = FSO.GetFolder(Ruta)
Set ficheros = Carpeta.Files
'damos un título en negrita para la celda A1
Range("A1").value = "Ficheros de la carpeta " & Ruta
Range("B1").value = "Fecha creación"
Range("C1").value = "Fecha último acceso"
Range("D1").value = "Fecha última modificación"
Range("E1").value = "Tipo archivo"
Range("F1").value = "Tamaño en bytes"
Range("G1").value = "Ruta corta"
Range("H1").value = "Nombre corto"
Range("I1").value = "Atributo"
Range("J1").value = "Ruta completa"
Range("A1:J1").Font.Bold = True
'escribimos los ficheros, a partir de A2
Range("A2").Select
For Each archivo In ficheros
'escribimos el nombre del fichero
activecell = archivo.Name
activecell.Offset(0, 1) = archivo.DateCreated
activecell.Offset(0, 2) = archivo.DateLastAccessed
activecell.Offset(0, 3) = archivo.DateLastModified
activecell.Offset(0, 4) = archivo.Type
activecell.Offset(0, 5) = archivo.Size
activecell.Offset(0, 6) = archivo.ShortPath
activecell.Offset(0, 7) = archivo.ShortName
activecell.Offset(0, 8) = archivo.Attributes
activecell.Offset(0, 9) = archivo.Path
'bajamos una fila
activecell.Offset(1, 0).Select
Next archivo
Range("A:J").EntireColumn.AutoFit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Limpiamos los objetos y variables definidas
Set FSO = Nothing
Set Carpeta = Nothing
Set ficheros = Nothing
Application.ScreenUpdating = True
End Sub
Sub abrirArchivo()
strArchivo = Application.GetOpenFilename
If strArchivo = False Then Exit Sub
Workbooks.OpenText Filename:=strArchivo
End Sub
