Link

B

Babs

Hi all,
I am in a fix. Can somebody help me with this code. I am
trying to pickup all system related details from location S:\ABC\Budget
2007\Budget2007\Central Functions\Submissions into spreadsheet on C:.
I am putting this code in a blank sheet.
But somehow it gives me error of "Script out of range". It gives error
at third statement Set sh = ThisWorkbook.Worksheets("DirList")
Can somebody please help me?
Its a bit urgent.
Thanking you
Regards,
Saumitra



Sub DirectorytoSheet()
Dim sh As Worksheet
Set sh = ThisWorkbook.Worksheets("DirList")
lstAttr = vbNormal + vbReadOnly + vbHidden
lstAttr = lstAttr + vbSystem + vbDirectory
lstAttr = lstAttr + vbArchive
myPath = "S:\ABC\Budget 2007\Budget2007\Central Functions\Submissions"
' Set the path.
myName = Dir(myPath, lstAttr) ' Retrieve the first entry.
sh.Cells(1, 1) = "Path:"
sh.Cells(1, 2) = myPath
sh.Cells(2, 2) = "Name"
sh.Cells(2, 3) = "Date"
sh.Cells(2, 4) = "Time"
sh.Cells(2, 5) = "Size"
sh.Cells(2, 6) = "Attr"
rw = 3
Do While myName <> "" ' Start the loop.
' Ignore the current directory and
' the encompassing directory.
If myName <> "." And myName <> ".." Then
sh.Cells(rw, 2) = myName
sh.Cells(rw, 3) = _
Int(FileDateTime(myPath & myName))
sh.Cells(rw, 4) = _
FileDateTime(myPath & myName) - _
Int(FileDateTime(myPath & myName))
sh.Cells(rw, 5) = _
FileLen(myPath & myName)
fattr = GetAttr(myPath & myName)
strAttr = ""
If fattr <> vbNormal Then '(vbNormal = 0 )
If (fattr And vbReadOnly) Then
strAttr = strAttr & "R"
End If
If (fattr And vbHidden) Then
strAttr = strAttr & "H"
End If
If (fattr And vbSystem) Then
strAttr = strAttr & "S"
End If
If (fattr And vbDirectory) Then
strAttr = strAttr & "D"
End If
If (fattr And vbArchive) Then
strAttr = strAttr & "A"
End If
End If
sh.Cells(rw, 6) = strAttr
rw = rw + 1
End If
myName = Dir ' Get next entry.
Loop
Intersect(sh.Range("A1").CurrentRegion, _
sh.Columns("C:C")).Offset(2, 0).NumberFormat = _
"mm/dd/yy"
Intersect(sh.Range("A1").CurrentRegion, _
sh.Columns("D:D")).Offset(2, 0).NumberFormat = _
"h:mm AM/PM"
End Sub
 
B

Bernie Deitrick

Is your blank sheet named "DirList"? If not,

Set sh = ThisWorkbook.Worksheets(1)

should work OK.

HTH,
Bernie
MS Excel MVP
 
B

Babs

Hi Bernie,
Now that problem is solved. The problem right now is in
statement
sh.Cells(rw, 3) = _
Int(FileDateTime(myPath & myName))

and gives error file not found, whereas the file exists in this folder.
It enters the loop and prints the name from myname.

Can you please help me?
Thanx
regards,
Saumitra

Sub DirectorytoSheet()
Dim sh As Worksheet
Set sh = ThisWorkbook.Worksheets("Sheet2")
lstAttr = vbNormal + vbReadOnly + vbHidden
lstAttr = lstAttr + vbSystem + vbDirectory
lstAttr = lstAttr + vbArchive
myPath = "C:\Documents and
Settings\kamats\Desktop\Saumitra\Budget\Finance Budget\Ashif v17.xls" '
Set the path.
myName = Dir(myPath, lstAttr) ' Retrieve the first entry.
sh.Cells(1, 1) = "Path:"
sh.Cells(1, 2) = myPath
sh.Cells(2, 2) = "Name"
sh.Cells(2, 3) = "Date"
sh.Cells(2, 4) = "Time"
sh.Cells(2, 5) = "Size"
sh.Cells(2, 6) = "Attr"
rw = 3
Do While myName <> "" ' Start the loop.
' Ignore the current directory and
' the encompassing directory.
If myName <> "." And myName <> ".." Then
sh.Cells(rw, 2) = myName
sh.Cells(rw, 3) = _
Int(FileDateTime(myPath & myName))
sh.Cells(rw, 4) = _
FileDateTime(myPath & myName) - _
Int(FileDateTime(myPath & myName))
sh.Cells(rw, 5) = _
FileLen(myPath & myName)
fattr = GetAttr(myPath & myName)
strAttr = ""
If fattr <> vbNormal Then '(vbNormal = 0 )
If (fattr And vbReadOnly) Then
strAttr = strAttr & "R"
End If
If (fattr And vbHidden) Then
strAttr = strAttr & "H"
End If
If (fattr And vbSystem) Then
strAttr = strAttr & "S"
End If
If (fattr And vbDirectory) Then
strAttr = strAttr & "D"
End If
If (fattr And vbArchive) Then
strAttr = strAttr & "A"
End If
End If
sh.Cells(rw, 6) = strAttr
rw = rw + 1
End If
myName = Dir ' Get next entry.
Loop
Intersect(sh.Range("A1").CurrentRegion, _
sh.Columns("C:C")).Offset(2, 0).NumberFormat = _
"mm/dd/yy"
Intersect(sh.Range("A1").CurrentRegion, _
sh.Columns("D:D")).Offset(2, 0).NumberFormat = _
"h:mm AM/PM"
End Sub
 
B

Bernie Deitrick

Babs,

I think you need to set the path just as a path:

myPath = "C:\Documents and Settings\kamats\Desktop\Saumitra\Budget\Finance Budget\"


HTH,
Bernie
MS Excel MVP
 
B

Babs

Thanx Bernie,
I think I have overcome that problem by changing
the macro to:

Filename = ":\Documents and
Settings\kamats\Desktop\Saumitra\Budget\Finance Budget"
updated = FileDateTime(Filename)

Range("a2").Select
ActiveCell.FormulaR1C1 = "Last updated"
Range("b2").Select
ActiveCell.FormulaR1C1 = Filename
Range("c2").Select
ActiveCell.FormulaR1C1 = updated

But th code does not pick up the files under that folder. The other
thing is I don't know how to write a do while loop to see all the
entries in the same folder. Can you please help me again? Its a bit
urgent.
Thanx
babs
 
B

Bernie Deitrick

Babs,

The code below worked for me.

HTH,
Bernie
MS Excel MVP

Sub DirectorytoSheet()
Dim sh As Worksheet
Set sh = ThisWorkbook.Worksheets("Sheet2")
lstAttr = vbNormal + vbReadOnly + vbHidden
lstAttr = lstAttr + vbSystem + vbDirectory
lstAttr = lstAttr + vbArchive
myPath = "C:\Documents and Settings\kamats\Desktop\Saumitra\Budget\Finance Budget\"

myName = Dir(myPath, lstAttr) ' Retrieve the first entry.
sh.Cells(1, 1) = "Path:"
sh.Cells(1, 2) = myPath
sh.Cells(2, 2) = "Name"
sh.Cells(2, 3) = "Date"
sh.Cells(2, 4) = "Time"
sh.Cells(2, 5) = "Size"
sh.Cells(2, 6) = "Attr"
rw = 3
Do While myName <> "" ' Start the loop.
' Ignore the current directory and
' the encompassing directory.
If myName <> "." And myName <> ".." Then
sh.Cells(rw, 2) = myName
sh.Cells(rw, 3) = _
Int(FileDateTime(myPath & "\" & myName))
sh.Cells(rw, 4) = _
FileDateTime(myPath & myName) - _
Int(FileDateTime(myPath & "\" & myName))
sh.Cells(rw, 5) = _
FileLen(myPath & myName)
fattr = GetAttr(myPath & "\" & myName)
strAttr = ""
If fattr <> vbNormal Then '(vbNormal = 0 )
If (fattr And vbReadOnly) Then
strAttr = strAttr & "R"
End If
If (fattr And vbHidden) Then
strAttr = strAttr & "H"
End If
If (fattr And vbSystem) Then
strAttr = strAttr & "S"
End If
If (fattr And vbDirectory) Then
strAttr = strAttr & "D"
End If
If (fattr And vbArchive) Then
strAttr = strAttr & "A"
End If
End If
sh.Cells(rw, 6) = strAttr
rw = rw + 1
End If
myName = Dir ' Get next entry.
Loop
Intersect(sh.Range("A1").CurrentRegion, _
sh.Columns("C:C")).Offset(2, 0).NumberFormat = _
"mm/dd/yy"
Intersect(sh.Range("A1").CurrentRegion, _
sh.Columns("D:D")).Offset(2, 0).NumberFormat = _
"h:mm AM/PM"
End Sub
 
B

Babs

Hi Bernie,
Thanks for your help. In addition to this,I would like
to see the contents of the subfolders also. Can you please help me on
this?

Regards,
babs
 
B

Bernie Deitrick

Babs,

Then Dir is the worng approach. See the macro below.

HTH,
Bernie
MS Excel MVP

Sub DirectorytoSheetSubFolder()
Dim sh As Worksheet
Set sh = ThisWorkbook.Worksheets("Sheet2")
lstAttr = vbNormal + vbReadOnly + vbHidden
lstAttr = lstAttr + vbSystem + vbDirectory
lstAttr = lstAttr + vbArchive

sh.Cells(1, 1) = "Path:"
sh.Cells(2, 2) = "Name"
sh.Cells(2, 3) = "Date"
sh.Cells(2, 4) = "Time"
sh.Cells(2, 5) = "Size"
sh.Cells(2, 6) = "Attr"
rw = 3

With Application.FileSearch
.NewSearch
.LookIn = "C:\Documents and Settings\kamats\Desktop\Saumitra\Budget\Finance Budget"
sh.Cells(1, 2) = .LookIn
.SearchSubFolders = True
If .Execute(msoSortOrderDescending) > 0 Then
MsgBox "There were " & .FoundFiles.Count & " file(s) found."
For i = 1 To .FoundFiles.Count

sh.Cells(rw, 2) = Replace(.FoundFiles(i), .LookIn & "\", "")
sh.Cells(rw, 3) = _
Int(FileDateTime(.FoundFiles(i)))
sh.Cells(rw, 4) = _
FileDateTime(.FoundFiles(i)) - _
Int(FileDateTime(.FoundFiles(i)))
sh.Cells(rw, 5) = _
FileLen(.FoundFiles(i))
fattr = GetAttr(.FoundFiles(i))
strAttr = ""
If fattr <> vbNormal Then '(vbNormal = 0 )
If (fattr And vbReadOnly) Then
strAttr = strAttr & "R"
End If
If (fattr And vbHidden) Then
strAttr = strAttr & "H"
End If
If (fattr And vbSystem) Then
strAttr = strAttr & "S"
End If
If (fattr And vbDirectory) Then
strAttr = strAttr & "D"
End If
If (fattr And vbArchive) Then
strAttr = strAttr & "A"
End If
End If
sh.Cells(rw, 6) = strAttr
rw = rw + 1
Next i
Else
MsgBox "There were no files found."
End If
End With

Intersect(sh.Range("A1").CurrentRegion, _
sh.Columns("C:C")).Offset(2, 0).NumberFormat = _
"mm/dd/yy"
Intersect(sh.Range("A1").CurrentRegion, _
sh.Columns("D:D")).Offset(2, 0).NumberFormat = _
"h:mm AM/PM"
End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Automation Error 2
macro listing subfolders from selection of mainfolders 1
Error 91: Object Variable Not Set 3
conditional copy of column to another column of same worksheet 0
Add code to paste data to next available row 7
I am so close....if null add new problem 2
Copy range if match 2
Find duplicated values and paste range results on next sheet - nextavailable row 0

Top