Create list of files within folder (and details), archive previous list

[jwb1012]

Hello, I am having some issues with a command I am trying to do. My goal is to have a worksheet saved in my folder C:\Users\1234\Desktop\Data .... with a macro button that does the following:

1. Copy/paste values of cells C2:E & "last row in column e" into column H2:K & "last row in column e"
2. Looks at filepath in B2 of "File Extraction" worksheet
3. Copy/pastes filenames and details of all files in this folder (file name, file path, file size, last modified date) in a table on the "File Extraction" worksheet beginning in C2

The purpose of step #1 is to leave a trail of the files within this folder the last time the macro was used.

I've found some code that I'm trying to modify, but cant seem to figure out how to fix these two glitches:

• Keeping that audit trail in step #1 (above)
• It only posts file name, but I also need file path, file size, last modified date
• It opens a window and makes me select the folder, instead of simply opening the folder I am trying to direct it to with "filename" variable in code

Any thoughts or suggestions?

Sub GetFileNames()
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$
Dim Filename As String
Filename = Format(Sheets("File Extraction").Range("A1") & ".xls")
InitialFoldr$ = "C:\"
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = Filename
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
Do While xFname$ <> ""
ActiveCell.Offset(xRow) = xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
End If
End With
End Sub

 

[tonyyy]

You might give the following a try...

Sub ListFilesWithInfo()

Dim FilePath As String
Dim Directory As String
Dim r As Long
Dim f As String
Dim FileSize As Double
Dim LastRow As Long

LastRow = Cells(Rows.Count, 3).End(xlUp).Row
Range("C2:F" & LastRow).Copy Destination:=Range("H2")

FilePath = Sheets("File Extraction").Range("B2")
If FilePath <> "" Then Directory = Left(FilePath, InStrRev(FilePath, "\"))
r = 2

''''  Insert headers
ActiveSheet.Cells(r, 3).Value = "FileName"
ActiveSheet.Cells(r, 4).Value = "FilePath"
ActiveSheet.Cells(r, 5).Value = "Size"
ActiveSheet.Cells(r, 6).Value = "DateModified"
ActiveSheet.Rows(2).Font.Bold = True

''''  Get first file
f = Dir(Directory, vbReadOnly + vbHidden + vbSystem)
Do While f <> ""
    r = r + 1
    ActiveSheet.Cells(r, 3).Value = f
    ActiveSheet.Cells(r, 4).Value = FilePath & f
''''  Adjust for filesize > 2 gigabytes
    FileSize = FileLen(Directory & f)
    If FileSize < 0 Then FileSize = FileSize + 4294967296#
    ActiveSheet.Cells(r, 5).Value = FileSize
    ActiveSheet.Cells(r, 6).Value = FileDateTime(Directory & f)
''''  Get next file
    f = Dir()
Loop
ActiveSheet.Columns.AutoFit
End Sub

The code doesn't clear the contents in Range("C2:F" & LastRow). This range will be overwritten with new data. If there are more files than the previous run, fine. If there are less files than the previous run, you may have some left overs.

Cheers,

tonyyy