How to write a macro to print a dir on my c drive

[Tony]

I have tried to right a macro to get the file nanes of the files in a dir on
my c; drive but only get \*.* as a results. And debug takes me to the
Print_file = dir() I can not get it to work. Can anyone tell me whats
incorrect in the file below.


Sub Print_Dir_Contents()
Dim Input_Dir, Print_File As String
Input_Dir = InputBox("Input the path containing the files you " & _
"want to list on your worksheet" & Chr(13) & Chr(13) & _
"for example:C:\My Documents\*.*")
If Input_Dir = "" Then Exit Sub
' If you want only to print a specific file type, you can
' substitute the "\*.*" with "*\.xl*"
' (for Excel files only) for the directory specified in the
' InputBox above.
If Application.OperatingSystem Like "*Win*" Then
Print_File = Dir(Input_Dir) & "\*.*"
End If
Range("a1").Select
Counter = 1
Do While Len(Print_File) > 0
Worksheets(ActiveSheet.Name).Cells(Counter, 1).Value = _
Print_File
Print_File = Dir()
Counter = Counter + 1
Loop
Thanks if you can help

Tony

 

[Don Guillett]

Here are a couple you might try

Sub GetFileList()
Dim iCtr As Integer
With Application.FileSearch
.NewSearch
.LookIn = "c:\aa"
.SearchSubFolders = True
.Filename = ".xls"
If .Execute > 0 Then
For iCtr = 1 To .FoundFiles.Count
Cells(iCtr, 1).Value = .FoundFiles(iCtr)
Next iCtr
End If
End With
End Sub

Sub FindExcelFiles()
Application.ScreenUpdating = False
Dim FN As String ' For File Name
Dim ThisRow As Long
Dim FileLocation As String
FileLocation = "c:\ahorse\*.xls"
FN = Dir(FileLocation)
Do Until FN = ""
ThisRow = ThisRow + 1
Cells(ThisRow, 1) = FN
FN = Dir
Loop
Application.ScreenUpdating = True
End Sub

 

[Bob Phillips]

Another way

Option Explicit

Dim FSO As Object
Dim cnt As Long
Dim arfiles
Dim level As Long


Sub Folders()
Dim i As Long
Dim sFolder As String
Dim iStart As Long
Dim iEnd As Long
Dim fOutline As Boolean

Set FSO = CreateObject("Scripting.FileSystemObject")

arfiles = Array()
cnt = -1
level = 1

sFolder = "c:\myTest"
ReDim arfiles(6, 0)
If sFolder <> "" Then
SelectFiles sFolder
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Files").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Worksheets.Add.Name = "Files"
With ActiveSheet
For i = LBound(arfiles, 2) To UBound(arfiles, 2)
If arfiles(0, i) = "" Then
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If
With .Cells(i + 1, arfiles(6, i))
.Value = arfiles(5, i)
.Font.Bold = True
End With
iStart = i + 1
iEnd = iStart
fOutline = False
Else
.Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(6, i)), _
Address:=arfiles(0, i), _
TextToDisplay:=arfiles(5, i)
.Cells(i + 1, arfiles(6, i) + 1).Value = arfiles(1, i)
.Cells(i + 1, arfiles(6, i) + 2).Value = arfiles(2, i)
.Cells(i + 1, arfiles(6, i) + 3).Value = arfiles(3, i)
.Cells(i + 1, arfiles(6, i) + 4).Value = arfiles(4, i)
iEnd = iEnd + 1
fOutline = True
End If
Next
.Columns("A:Z").Columns.AutoFit
End With
End If
'just in case there is another set to group
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If

ActiveSheet.Outline.ShowLevels RowLevels:=1
ActiveWindow.DisplayGridlines = False

End Sub


'-----------------------------­­­----------------------------­-­-­----------
--
Sub SelectFiles(Optional sPath As String)
'-----------------------------­­­----------------------------­-­-­----------
--
Dim oSubFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim arPath

arPath = Split(sPath, "\")
cnt = cnt + 1
ReDim Preserve arfiles(6, cnt)
arfiles(0, cnt) = ""
arfiles(5, cnt) = arPath(level - 1)
arfiles(6, cnt) = level

Set oFolder = FSO.GetFolder(sPath)
Set oFiles = oFolder.Files
For Each oFile In oFiles
cnt = cnt + 1
ReDim Preserve arfiles(6, cnt)
arfiles(0, cnt) = oFolder.Path & "\" & oFile.Name
arfiles(1, cnt) = Right(oFile.Name, Len(oFile.Name) - _
InStrRev(oFile.Name, "."))
arfiles(2, cnt) = Format(oFile.DateCreated, "dd mmm yyyy")
arfiles(3, cnt) = Format(oFile.Size, "#,##0")
arfiles(4, cnt) = oFile.Path
arfiles(5, cnt) = oFile.Name
arfiles(6, cnt) = level + 1
Next oFile

level = level + 1
For Each oSubFolder In oFolder.Subfolders
SelectFiles oSubFolder.Path
Next
level = level - 1

End Sub


#If VBA6 Then
#Else
'-----------------------------­­-----------------------------­-­------
Function Split(Text As String, _
Optional Delimiter As String = ",") As Variant
'-----------------------------­­-----------------------------­-­------
Dim i As Long
Dim sFormula As String
Dim aryEval
Dim aryValues

If Delimiter = vbNullChar Then
Delimiter = Chr(7)
Text = Replace(Text, vbNullChar, Delimiter)
End If

sFormula = "{""" & Application.Substitute(Text, Delimiter, """,""") &
"""}"
aryEval = Evaluate(sFormula)
ReDim aryValues(0 To UBound(aryEval) - 1)
For i = 0 To UBound(aryValues)
aryValues(i) = aryEval(i + 1)
Next

Split = aryValues

End Function

#End If






--

HTH

RP
(remove nothere from the email address if mailing direct)